Solved

VBA Export to Excel problems

Posted on 2009-05-19
6
589 Views
Last Modified: 2013-11-28
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
0
Comment
Question by:saved4use
[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
  • 3
  • 2
6 Comments
 
LVL 3

Expert Comment

by:jakemdrew
ID: 24425120
Does the code you have attached run?  Are ouhaving problems with errors?  I am not really understanding what your question is.
0
 

Author Comment

by:saved4use
ID: 24425182
the code runs fine, but it is not adding the two metrics I want as reflected in the attached Excel called AFTER.
0
 
LVL 74

Expert Comment

by:Jeffrey Coachman
ID: 24425944
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
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

Author Comment

by:saved4use
ID: 24426034
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
 
LVL 74

Accepted Solution

by:
Jeffrey Coachman earned 500 total points
ID: 24426666
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
 
LVL 74

Expert Comment

by:Jeffrey Coachman
ID: 24445753
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

Featured Post

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

It’s been over a month into 2017, and there is already a sophisticated Gmail phishing email making it rounds. New techniques and tactics, have given hackers a way to authentically impersonate your contacts.How it Works The attack works by targeti…
As tax season makes its return, so does the increase in cyber crime and tax refund phishing that comes with it
Many functions in Excel can make decisions. The most simple of these is the IF function: it returns a value depending on whether a condition you describe is true or false. Once you get the hang of using the IF function, you will find it easier to us…
With Secure Portal Encryption, the recipient is sent a link to their email address directing them to the email laundry delivery page. From there, the recipient will be required to enter a user name and password to enter the page. Once the recipient …

752 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