Solved

Access Table to Excel with formatting

Posted on 2013-05-13
12
286 Views
Last Modified: 2013-05-14
I have a student grades database (A2010) where I want to export a grades table to an Excel workbook where the export creates a tab for the day and exports the data to that specific date tab. Where I'm struggling with code is testing to see if the date already exists, overwrite the data; if the date does not exist, create a new tab and export data. I also want to set column widths and turn on filtering to make the spreadsheet more user friendly. Here is the code I've pieced together from the internet:
Public Function ExportGrades()

Dim strTab As String
Dim strFileName As String
Dim strWkSt As String
Dim strWkbkName As String
Dim objXL As Object

strFileName = Application.CurrentProject.Path & "\CurrentQtrGrades.xls"
strTab = Format(Now, "mmdd")

'DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "tblCurrentQtrGrades", _
'    strFileName, True, strTab
    
DoCmd.TransferSpreadsheet transfertype:=acExport, _
    spreadsheettype:=acSpreadsheetTypeExcel9, _
    TableName:="tblCurrentQtrGrades", _
    FileName:=strFileName, _
    hasfieldnames:=True, _
    range:=strTab
    
strWkbkName = strFileName
    
     strWkSt = strTab
    Set objXL = CreateObject("Excel.Application")
    objXL.Workbooks.Open (strWkbkName)
    With objXL
        .Worksheets(strWkSt) _
        .Rows("1:1").Font.Bold = True
        .Columns("A:Z").Autofit
        .Cells.Rows(1).AutoFilter
        .Save
        .Workbooks.Close
    End With
End Function

Open in new window


I am running into problems with the modifications of the Excel file as this code has to open the file - which appears to be creating some problems.

Thanks in advance.
0
Comment
Question by:Heartless91
  • 6
  • 5
12 Comments
 
LVL 92

Expert Comment

by:Patrick Matthews
ID: 39162010
which appears to be creating some problems

Like what, specifically?
0
 
LVL 119

Accepted Solution

by:
Rey Obrero earned 500 total points
ID: 39162069
try this revised codes


Public Function ExportGrades()

Dim strTab As String
Dim strFileName As String
Dim strWkSt As String
Dim strWkbkName As String
Dim objXL As Object, shtFound as boolean
Dim j as Integer, shtCount as integer, rowCnt as integer,colCnt as Integer
Dim rs as dao.recordset      
set rs=currentdb.openrecordset("tblCurrentQtrGrades")

strFileName = Application.CurrentProject.Path & "\CurrentQtrGrades.xls"
strTab = Format(Now, "mmdd")

set objXl=createobject("excel.application")
    objXL.workbooks.open strFileName
      
      shtCount=objXl.worksheets.count
      
      for j= 1 to shtCount
            if objXl.worsheets(j).name=strTab then
                  shtFound=true
                  exit for
            end if      
      next
      
      if Not shtFound then
            'add a worksheet
            objXL.worksheets.add after:=objXL.worsksheets(shtCount)
            shtCount=shtCount + 1
            objXL.worsksheets(shtCount).name= strTab
      end if
      
      with objXl
            .worksheets(strTab).activate
            'delete content
                  .cells.select
                  .selection.delete
            'populate the header
            
              For j = 0 To rs.Fields.Count - 1
                         .ActiveSheet.cells(1, j + 1).Value = rs(j).Name
               Next
              'copy the records
                    .ActiveSheet.Range("A2").copyfromrecordset rs
               rowCnt = .ActiveSheet.UsedRange.Rows.Count
               colCnt = .ActiveSheet.UsedRange.columns.Count
            
                         .Range("A1:" & Chr(64 + colCnt) & 1).Select
                         .Selection.AutoFilter
                        .Selection.columns.autofit
                        .Selection.Font.Bold = True
                        .activeworkbook.save
      end with
      
      objXl.quit
      
      End Function
0
 

Author Comment

by:Heartless91
ID: 39162148
Receiving an error:

Run-time error '438':
Object doesn't support this property or method

Referencing
 if objXl.worsheets(j).name=strTab then
0
 
LVL 119

Assisted Solution

by:Rey Obrero
Rey Obrero earned 500 total points
ID: 39162199
sorry, typo, it should be

 if objXl.worksheets(j).name=strTab then



use this codes


Public Function ExportGrades()

Dim strTab As String
Dim strFileName As String
Dim strWkSt As String
Dim strWkbkName As String
Dim objXL As Object, shtFound as boolean
Dim j as Integer, shtCount as integer, rowCnt as integer,colCnt as Integer
Dim rs as dao.recordset      
set rs=currentdb.openrecordset("tblCurrentQtrGrades")

strFileName = Application.CurrentProject.Path & "\CurrentQtrGrades.xls"
strTab = Format(Now, "mmdd")

set objXl=createobject("excel.application")
    objXL.workbooks.open strFileName
     
      shtCount=objXl.worksheets.count
     
      for j= 1 to shtCount
            if objXl.worksheets(j).name=strTab then
                  shtFound=true
                  exit for
            end if      
      next
     
      if Not shtFound then
            'add a worksheet
            objXL.worksheets.add after:=objXL.worksheets(shtCount)
            shtCount=shtCount + 1
            objXL.worksheets(shtCount).name= strTab
      end if
     
      with objXl
            .worksheets(strTab).activate
            'delete content
                  .cells.select
                  .selection.delete
            'populate the header
           
              For j = 0 To rs.Fields.Count - 1
                         .ActiveSheet.cells(1, j + 1).Value = rs(j).Name
               Next
              'copy the records
                    .ActiveSheet.Range("A2").copyfromrecordset rs
               rowCnt = .ActiveSheet.UsedRange.Rows.Count
               colCnt = .ActiveSheet.UsedRange.columns.Count
           
                         .Range("A1:" & Chr(64 + colCnt) & 1).Select
                         .Selection.AutoFilter
                        .Selection.columns.autofit
                        .Selection.Font.Bold = True
                        .activeworkbook.save
      end with
     
      objXl.quit
     
      End Function
0
 

Author Comment

by:Heartless91
ID: 39162262
I caught the typo just a few moments ago. The code runs without error but when I open the Excel file, it opens and closes. It shows as a process in Windows Task Manager. Once I quit the process, then I can open the file. I can see that it did the overwrite but it did not turn on the autofiltering.

Hmmmm. Ran it again, autofiltering worked but autofit didn't...
0
 
LVL 119

Expert Comment

by:Rey Obrero
ID: 39162284
<It shows as a process in Windows Task Manager. >
that could have been caused by the previous error.


<but it did not turn on the autofiltering. > are you sure
this line should do it
 
             .Selection.AutoFilter


try running again the codes
0
What Is Threat Intelligence?

Threat intelligence is often discussed, but rarely understood. Starting with a precise definition, along with clear business goals, is essential.

 

Author Comment

by:Heartless91
ID: 39162429
Ran again with everything working but the autofit.
0
 
LVL 119

Assisted Solution

by:Rey Obrero
Rey Obrero earned 500 total points
ID: 39162479
change this part

           
                         .Range("A1:" & Chr(64 + colCnt) & 1).Select
                         .Selection.AutoFilter
                        .Selection.columns.autofit
                        .Selection.Font.Bold = True
                        .activeworkbook.save


with


                         .Range("A1:" & Chr(64 + colCnt) & 1).Select
                         .Selection.AutoFilter
                   
                        .Selection.Font.Bold = True
                       
                                    
                  .Range("A1:" & Chr(64 + colCnt) & rowCnt).Select
                  .Selection.columns.autofit
                  .activeworkbook.save


.
0
 

Author Comment

by:Heartless91
ID: 39164430
Modified code per your instructions. Everything works... I think.

The code hung this morning due to some typos. Once that was corrected, it ran but since the sheet already existed, it did not execute the autofit or the autofilter. I deleted the sheet and reran the code and everything worked.

As I see it, two problems still exist:
1) The first time the Excel file is opened after running, the entire sheet is selected. I can see the potential for a user to inadvertently delete the data. I added the following code after the  Autofit code. It looks like:
            .Selection.Columns.AutoFit
            .Range("A1:A1").Select

2) The second problem I hadn't considered and I understand if this is a separate issue. I didn't consider what would happen if a user deleted or moved the file. I recognize the need to check for the file before trying to open it - or - will it automatically create the file if it doesn't exist?

Thanks again. You have already been a tremendous help.
0
 

Author Comment

by:Heartless91
ID: 39164458
Modified code per your instructions. Everything works... I think.

The code hung this morning due to some typos. Once that was corrected, it ran but since the sheet already existed, it did not execute the autofit or the autofilter. I deleted the sheet and reran the code and everything worked.

As I see it, two problems still exist:
1) The first time the Excel file is opened after running, the entire sheet is selected. I can see the potential for a user to inadvertently delete the data. I added the following code after the  Autofit code. It looks like:
            .Selection.Columns.AutoFit
            .Range("A1:A1").Select                        'This is the line I added

2) The second problem I hadn't considered and I understand if this is a separate issue. I didn't consider what would happen if a user deleted or moved the file. I recognize the need to check for the file before trying to open it - or - will it automatically create the file if it doesn't exist?

Thanks again. You have already been a tremendous help.
0
 
LVL 119

Expert Comment

by:Rey Obrero
ID: 39164487
< I recognize the need to check for the file before trying to open it - or - will it automatically create the file if it doesn't exist?>

with the current codes, it will raise an error if the file does not exists.
0
 

Author Closing Comment

by:Heartless91
ID: 39164810
Great help! Thanks.
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

A little background as to how I came to I design this code: Around 5 years ago I designed an add-in that formatted Excel files to a corporate standard, applying different cell colours and font type depending on whether the cells contained inputs,…
I see at least one EE question a week that pertains to using temporary tables in MS Access.  But surprisingly, I was unable to find a single article devoted solely to this topic. I don’t intend to describe all of the uses of temporary tables in t…
The view will learn how to download and install SIMTOOLS and FORMLIST into Excel, how to use SIMTOOLS to generate a Monte Carlo simulation of 30 sales calls, and how to calculate the conditional probability based on the results of the Monte Carlo …
The viewer will learn how to create a normally distributed random variable in Excel, use a normal distribution to simulate the return on an investment over a period of years, Create a Monte Carlo simulation using a normal random variable, and calcul…

746 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

9 Experts available now in Live!

Get 1:1 Help Now