Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 356
  • Last Modified:

Access Table to Excel with formatting

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
Heartless91
Asked:
Heartless91
  • 6
  • 5
3 Solutions
 
Patrick MatthewsCommented:
which appears to be creating some problems

Like what, specifically?
0
 
Rey Obrero (Capricorn1)Commented:
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
 
Heartless91Author Commented:
Receiving an error:

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

Referencing
 if objXl.worsheets(j).name=strTab then
0
NFR key for Veeam Backup for Microsoft Office 365

Veeam is happy to provide a free NFR license (for 1 year, up to 10 users). This license allows for the non‑production use of Veeam Backup for Microsoft Office 365 in your home lab without any feature limitations.

 
Rey Obrero (Capricorn1)Commented:
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
 
Heartless91Author Commented:
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
 
Rey Obrero (Capricorn1)Commented:
<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
 
Heartless91Author Commented:
Ran again with everything working but the autofit.
0
 
Rey Obrero (Capricorn1)Commented:
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
 
Heartless91Author Commented:
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
 
Heartless91Author Commented:
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
 
Rey Obrero (Capricorn1)Commented:
< 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
 
Heartless91Author Commented:
Great help! Thanks.
0

Featured Post

Nothing ever in the clear!

This technical paper will help you implement VMware’s VM encryption as well as implement Veeam encryption which together will achieve the nothing ever in the clear goal. If a bad guy steals VMs, backups or traffic they get nothing.

  • 6
  • 5
Tackle projects and never again get stuck behind a technical roadblock.
Join Now