VBA Export to Excel problems

I have a report that I now need to add two metrics Surveys Returned and First Call Resolution, and cannot figure out how to. Can someone please look at the Make Excel code below and let me know how I can do this. I have attached the file before and after Excel files..
Option Compare Database
Option Explicit
 
Public Sub MakeExcel(strRpt, strPath)
On Error GoTo Err_MakeExcel
   
    'Send Data
    Dim xlApp As Object
    Dim xlWorkbook As Object
    Dim xlSheet As Object, xlSheetCopyFrom As Object
    Dim i As Integer, r As Integer
    Dim n As Integer
    Dim intStart As Integer, intEnd As Integer
    Dim strName As String, strNameNew
    Dim intGroupStartOld As Integer
    Dim intGroupNameStart As Integer
    Dim strFile As String, strFilePath As String
    Dim intPageCnt As Integer, p As Integer
    Dim strSheetName As String
    
    
    'NOTE: to read value of cell use format .cells(r,c)
    ' Where r equals the row number and c equals the column number instead of .Range("A1")
    
    DoCmd.SetWarnings False
    
    intPageCnt = DSum("[Pgs]", "qryRpt011_LdrsPages")
   
    'Export data
    strFile = strRpt & " " & Format(Forms!frmReport!txtToDate, "yyyymm") & ".xls"
    strFilePath = strPath & "\" & strFile
    Kill strFilePath
    DoCmd.TransferSpreadsheet acExport, 8, "qryRpt011DeptPerformanceExcel_Hdr", strFilePath, True
    DoCmd.TransferSpreadsheet acExport, 8, "qryRpt011DeptPerformanceExcel", strFilePath, True
    DoCmd.TransferSpreadsheet acExport, 8, "tblDateLabels", strFilePath, True
        
   
    'Add extra pages
    DoEvents
    Set xlApp = GetObject(, "Excel.Application")
    Set xlWorkbook = xlApp.Workbooks.Open(strFilePath)
    xlApp.Visible = True
    For i = 2 To intPageCnt
        xlWorkbook.Sheets("tblDateLabels").Select
        xlWorkbook.ActiveSheet.Copy After:=xlWorkbook.Sheets(i + 1)
        'rename the new sheet
        xlWorkbook.ActiveSheet.Name = "tblDateLabels" & i
    Next i
    
    'Create header section on first "tblDateLabels" tab
    'This will be copied to each of the other sections
    Set xlSheet = xlWorkbook.Sheets(3)
   
    With xlSheet
        'Format first row - the DateLabel row
        xlApp.CutCopyMode = False
        .Rows("1:1").Delete Shift:=-4162
        .Range("A1") = "Metrics"
        .Range("O1") = "YTD"
        .Range("P1") = "3M"
        With .Range("A1:P1")
            .Interior.ColorIndex = 37
            .Interior.Pattern = 1
            For n = 7 To 11
                With .Borders(n)
                    .LineStyle = 1 'xlContinuous
                    .Weight = 2 'xlThin
                    .ColorIndex = -4105 'xlAutomatic
                End With
            Next n
        End With
        'formatting the second row
        .Range("A2") = "Operations Support"
        .Range("A2:P2").Interior.ColorIndex = 35
        .Range("A2:P2").Interior.Pattern = 1
    End With
        
    With xlWorkbook.Sheets(1)
        'Format numbers according to "View As" column information
        'based on "qryRpt011DeptPerformanceExcel_Hdr" tab
        .Range("B2:B8").Copy xlSheet.Range("A3")
        xlApp.CutCopyMode = False
        For i = 2 To 8
            strName = .cells(i, 18)
            If strName = "Percent1" Then
                .Range("C" & i & ":Q" & i).NumberFormat = "0.0%"
            ElseIf strName = "Percent2" Then
                .Range("C" & i & ":Q" & i).NumberFormat = "0.00%"
            ElseIf strName = "2 Decimal" Then
                .Range("C" & i & ":Q" & i).NumberFormat = "0.00"
            ElseIf strName = "Integer" Then
                .Range("C" & i & ":Q" & i).NumberFormat = "0"
            End If
        Next i
          
        .Range("C2:Q8").Copy xlSheet.Range("B3")
    End With
    'Format new data that has been added to the first leaders tab
    With xlSheet
        With .Range("A3:P9")
            .Interior.ColorIndex = 15
            .Interior.Pattern = 1 'xlSolid
            For n = 7 To 12
                With .Borders(n)
                    .LineStyle = 1 'xlContinuous
                    .Weight = 2 'xlThin
                    .ColorIndex = -4105 'xlAutomatic
                End With
            Next n
           
        End With
    End With
    
    'copy Operations support header information from the first leader tab
    'to all the other leader tabs
    For i = 4 To 2 + intPageCnt
        xlSheet.Range("A1:P9").Copy xlWorkbook.Sheets(i).Range("A1")
    Next i
    
    'Prepare data in "qryRpt011DeptPerformanceExcel" tab
    'format number fields which will be copied into individual leaders tabs
    With xlWorkbook.Sheets(2)
        'Find number of rows in sheet
        r = 1
        For r = 1 To 200
            If Len(.cells(r, 1)) = 0 Then
                r = r - 1
                r = 200
            End If
        Next r
        
        'Format numbers according to "View As" information
        For i = 2 To r
            strName = .cells(i, 19)
            If strName = "Percent1" Then
                .Range("D" & i & ":R" & i).NumberFormat = "0.0%"
            ElseIf strName = "Percent2" Then
                .Range("D" & i & ":R" & i).NumberFormat = "0.00%"
            ElseIf strName = "2 Decimal" Then
                .Range("D" & i & ":R" & i).NumberFormat = "0.00"
            ElseIf strName = "Integer" Then
                .Range("D" & i & ":R" & i).NumberFormat = "0"
            End If
        Next i
    End With
    
    'Create 1 spreadsheet for each site leader
    Set xlSheetCopyFrom = xlWorkbook.Sheets(2)
    i = 1
    intStart = 2 'Starting Row in copy from sheet
    'give strNameNew a value so that its length is greater than 0 to start
    strNameNew = "Start"
    intGroupStartOld = 2  'row where first group name appears
    For p = 3 To 2 + intPageCnt
        Set xlSheet = xlWorkbook.Sheets(p)
        With xlSheet
            .Range("A:A").ColumnWidth = 23
                      
            i = intStart
            'Loop through data until the rows are empty
            
            r = 1
            strName = xlSheetCopyFrom.cells(intStart, 1)
            strNameNew = xlSheetCopyFrom.cells(intStart, 1)
            Do Until strNameNew <> strName Or Len(strNameNew) = 0 Or r = 35
                strNameNew = xlSheetCopyFrom.cells(i, 1)
                r = r + 1
                i = i + 1
            Loop
             
            'back up one row to get last row number before the leader's name changes
            'or end of page because page is full after 35 rows
            intEnd = i - 2
            
            'Copy leader's name into "A10"
             xlSheet.Range("A2:R2").Copy .Range("A10")
            .Range("A10") = strName
            'rename sheet
            strSheetName = strName
            .Name = strSheetName
            
            'Get each Group and copy data onto new sheet
            
            intGroupNameStart = 11 'starting on each new sheet
            'Loop through " copy from sheet" until through all rows for that leader
            'or page is full, more than 35 rows
            Do Until intGroupStartOld > intEnd
                'copy green row
                xlSheet.Range("A2:R2").Copy xlSheet.Range("A" & intGroupNameStart)
                'and enter value for group name
                xlSheet.Range("A" & intGroupNameStart) = "      " & xlSheetCopyFrom.cells(intGroupStartOld, 2)
                'copy metrics rows
                xlSheetCopyFrom.Range("C" & intGroupStartOld & ":R" & (intGroupStartOld + 6)).Copy xlSheet.Range("A" & (intGroupNameStart + 1))
                With .Range("A" & (intGroupNameStart + 1) & ":P" & (intGroupNameStart + 7))
                    For n = 7 To 12
                        With .Borders(n)
                            .LineStyle = 1 'xlContinuous
                            .Weight = 2 'xlThin
                            .ColorIndex = -4105 'xlAutomatic
                        End With
                    Next n
                End With
                
                intGroupStartOld = intGroupStartOld + 7
                intGroupNameStart = intGroupNameStart + 8
            Loop
                
            If Len(strNameNew) <> 0 Then
                'change strNameNew so that both strName and strNameNew are the same
                'when you start the name check loop again.
                'unless it's the end of the data
                strNameNew = strName
                'Get new starting row, based on last ending row
                intStart = intEnd + 1
            End If
        End With
    Next p
    
    xlApp.DisplayAlerts = False
    xlWorkbook.Sheets(2).Delete
    xlWorkbook.Sheets(1).Delete
    xlApp.DisplayAlerts = True
    
Exit_MakeExcel:
    xlWorkbook.Save
    xlWorkbook.Close
    xlApp.Quit
    DoCmd.SetWarnings True
    Forms!frmReport!txtMsg = strRpt & " printed to " & strFilePath
    Exit Sub
 
Err_MakeExcel:
    If Err.Number = 429 Then
        Set xlApp = CreateObject("Excel.Application")
        Resume Next
    ElseIf Err.Number = 53 Then 'file not found
        Resume Next
    ElseIf Err.Number = 1004 Then 'Cannot rename a sheet to the same name as another sheet
        strSheetName = strName & " Pg 2"
        Resume
    Else
        MsgBox Err.Description
        Resume 'Exit_MakeExcel
    End If
    
End Sub

Open in new window

SummaryByDept-200904-AFTER.xlsx
saved4useAsked:
Who is Participating?

Improve company productivity with a Business Account.Sign Up

x
 
Jeffrey CoachmanConnect With a Mentor MIS LiasonCommented:
You have not stated what version of Office you are using, so I will speak in general terms.

The "Export to Excel" function for reports, was never, ...and will never be, perfect.

*Especialy* when it comes to headers and footers.
Access Report and Excel sheets are two totally different objects.
Excel is a Grid.
Access Reports are meant to be "Graphical".

Most developers Export the underlying Query to Excel, then use code to

Again, can you direct me to the specific section of code where you are trying to insert the Metrics into the Excel Header?
Also can you post a sample of the Access database, cleary identfying these "Metrics"

Thanks

JeffCoachman
0
 
jakemdrewCommented:
Does the code you have attached run?  Are ouhaving problems with errors?  I am not really understanding what your question is.
0
 
saved4useAuthor Commented:
the code runs fine, but it is not adding the two metrics I want as reflected in the attached Excel called AFTER.
0
Get 10% Off Your First Squarespace Website

Ready to showcase your work, publish content or promote your business online? With Squarespace’s award-winning templates and 24/7 customer service, getting started is simple. Head to Squarespace.com and use offer code ‘EXPERTS’ to get 10% off your first purchase.

 
Jeffrey CoachmanMIS LiasonCommented:
saved4use,

To save us time, can you refer us to the section of code where you are trying to add these two "Metrics"?

Also can you state what these "Metrics are, and were are they in the Access Database?

JeffCoachman
0
 
saved4useAuthor Commented:
The two metrics Surveys Returned and First Call Resolution already appear in the source query. However, when it comes to exporting the report to EXCEL based on this code, the don't appear in the header, and they also appear in the subreports in the wrong place.
Wghat do I need to change in my code to accommodate two new metrics?
SummaryByDept-200903-BEFORE.xlsx
0
 
Jeffrey CoachmanMIS LiasonCommented:
oops.

I had an unfinished thought above:

Should be:

Most developers Export the underlying Query to Excel, then use code to format the Excel file as needed.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.