?
Solved

Access Table to Excel with formatting

Posted on 2013-05-13
12
Medium Priority
?
341 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
[X]
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
  • 6
  • 5
12 Comments
 
LVL 93

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 2000 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
Microsoft Certification Exam 74-409

Veeam® is happy to provide the Microsoft community with a study guide prepared by MVP and MCT, Orin Thomas. This guide will take you through each of the exam objectives, helping you to prepare for and pass the examination.

 
LVL 120

Assisted Solution

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

On Demand Webinar - Networking for the Cloud Era

This webinar discusses:
-Common barriers companies experience when moving to the cloud
-How SD-WAN changes the way we look at networks
-Best practices customers should employ moving forward with cloud migration
-What happens behind the scenes of SteelConnect’s one-click button

Question has a verified solution.

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

This article describes a method of delivering Word templates for use in merging Access data to Word documents, that requires no computer knowledge on the part of the recipient -- the templates are saved in table fields, and are extracted and install…
If you need a simple but flexible process for maintaining an audit trail of who created, edited, or deleted data from a table, or multiple tables, and you can do all of your work from within a form, this simple Audit Log will work for you.
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.
Visualize your data even better in Access queries. Given a date and a value, this lesson shows how to compare that value with the previous value, calculate the difference, and display a circle if the value is the same, an up triangle if it increased…

777 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