Link to home
Start Free TrialLog in
Avatar of saved4use
saved4useFlag for United States of America

asked on

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
Avatar of jakemdrew
jakemdrew

Does the code you have attached run?  Are ouhaving problems with errors?  I am not really understanding what your question is.
Avatar of saved4use

ASKER

the code runs fine, but it is not adding the two metrics I want as reflected in the attached Excel called AFTER.
Avatar of Jeffrey Coachman
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
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
ASKER CERTIFIED SOLUTION
Avatar of Jeffrey Coachman
Jeffrey Coachman
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
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.