Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people, just like you, are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
Solved

Access Table to Excel with formatting

Posted on 2013-05-13
12
319 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 120

Accepted Solution

by:
Rey Obrero (Capricorn1) 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
Complete VMware vSphere® ESX(i) & Hyper-V Backup

Capture your entire system, including the host, with patented disk imaging integrated with VMware VADP / Microsoft VSS and RCT. RTOs is as low as 15 seconds with Acronis Active Restore™. You can enjoy unlimited P2V/V2V migrations from any source (even from a different hypervisor)

 
LVL 120

Assisted Solution

by:Rey Obrero (Capricorn1)
Rey Obrero (Capricorn1) 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 120

Expert Comment

by:Rey Obrero (Capricorn1)
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
 

Author Comment

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

Assisted Solution

by:Rey Obrero (Capricorn1)
Rey Obrero (Capricorn1) 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 120

Expert Comment

by:Rey Obrero (Capricorn1)
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

Ransomware: The New Cyber Threat & How to Stop It

This infographic explains ransomware, type of malware that blocks access to your files or your systems and holds them hostage until a ransom is paid. It also examines the different types of ransomware and explains what you can do to thwart this sinister online threat.  

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

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,…
Excel can be a tricky bit of software to get your head around. Whilst you’ll be able to eventually get to grips with the basic understanding of how to get by, there are a few Excel tips that not everybody will even know about let alone know how to d…
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…

809 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