saved4use
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
SummaryByDept-200904-AFTER.xlsx
Does the code you have attached run? Are ouhaving problems with errors? I am not really understanding what your question is.
ASKER
the code runs fine, but it is not adding the two metrics I want as reflected in the attached Excel called AFTER.
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
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
ASKER
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
Wghat do I need to change in my code to accommodate two new metrics?
SummaryByDept-200903-BEFORE.xlsx
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
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.
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.