Solved

VBA Export to Excel problems

Posted on 2009-05-19
6
583 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
  • 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
Free Trending Threat Insights Every Day

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

 

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

Threat Intelligence Starter Resources

Integrating threat intelligence can be challenging, and not all companies are ready. These resources can help you build awareness and prepare for defense.

Join & Write a Comment

How to quickly and accurately populate Word documents with Excel data, charts and images (including Automated Bookmark generation) David Miller (dlmille) Synopsis In this article you’ll learn how to use ExcelToWord! to copy data,charts, shapes …
This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
Graphs within dashboards are meant to be dynamic, representing data from a period of time that will change each time the dashboard is updated with new data. Rather than update each graph to point to a different set within a static set of data, t…
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.

759 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

Need Help in Real-Time?

Connect with top rated Experts

20 Experts available now in Live!

Get 1:1 Help Now