Here is an example I use to create a report in Excel. This should give you
an idea of what is necessary:
Sub Build_XL_Report()
Const conLightGray As Long = 12632256
Const conLightBlue As Long = 16777164
Const conLightYellow As Long = 10092543
Dim xlApp As Object 'Application Object
Dim xlBook As Object 'Workbook Object
Dim xlsheet As Object 'Worksheet Object
Dim varFileName As Variant 'File Name of Spreadsheet
Dim varFolderName As Variant 'Location of Spreadsheet
Dim varGetFileName As Variant 'File Name with Full Path
Dim blnSaveFile As Boolean 'Save the File?
Dim rstSCCB As Recordset 'Recordset to load data from
Dim rstItms As Recordset 'Recordset to load ITM Name in Header
Dim qdf As QueryDef 'Query def to load data
Dim lngItmCount As Long 'Number of ITMs in the RecordSet
Dim lngDetailCount As Long 'Number of Detail Data rows in the recordset
Dim intX As Integer 'Loop Counter
Dim strMonth As String 'Used to create a Short month name ie
January to Jan
Dim strCurrItm As String 'Hold the ITM Name to format Total cell
Dim lngRowCount As Long 'A loop counter that gives the current row
reference
Dim lngTotalPos As Long 'Used to format ITM Total cells
Dim strPrintArea As String 'Defines the print area for the sheet
Dim strTitleRows As String 'Defines the rows to print at the top of
each page
Dim blnFileSaved As Boolean 'Used in Do Loop for saving file to disk
Dim strLeftRange As String 'Used to format range references
Dim strRightRange As String 'Used to format range references
Dim lngFirstDataRow As Long 'The first row with detail data
Dim lngLastDataRow As Long 'The last row with detail data
Dim blnOkToShow As Boolean 'Only show the file if we saved it
On Error GoTo Build_XL_Report_ERR
DoCmd.Hourglass (True)
Me.txtStatus = "Updating Queries"
Me.txtStatus.Visible = True
'Fix the Queries so you dont have to be hand each month
Call FixSql("qselsccbactual", "actual_res_export")
Call FixSql("qselsccbactualtot", "actual_res_export")
Me.txtStatus = "Getting ITM Data"
Me.Repaint
'Set up the necessary objcts
On Error Resume Next ' Defer error trapping.
Set xlApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
blnExcelWasNotRunning = True
Set xlApp = CreateObject("excel.application")
Else
DetectExcel
End If
Err.Clear ' Clear Err object in case error occurred.
On Error GoTo Build_XL_Report_ERR
xlApp.DisplayAlerts = False
xlApp.Interactive = False
xlApp.ScreenUpdating = False
Set xlBook = xlApp.Workbooks.Add
Me.txtStatus = "Building Workbook"
Me.Repaint
'Remove excess worksheets
Do While xlBook.Worksheets.Count > 1
xlApp.Worksheets(xlApp.Worksheets.Count).Delete
Loop
Set xlsheet = xlBook.ActiveSheet
'Build The Spreadsheet
'Build The Headers
Me.txtStatus = "Creating Headers"
Me.Repaint
strMonth = Left(Me.cboPeriod.Column(1), 3)
xlsheet.Name = Me.cboResource & " Hours " & strMonth & " YTD"
With xlsheet
.Cells(1, 1) = "ITM"
.Cells(1, 2) = Me.txtCurrYear & _
" Activity # Description"
.Cells(1, 3) = "Budget " & Me.txtCurrYear
.Cells(1, 4).Value = Me.txtCurrYear & " YTD Budget"
.Cells(1, 5) = "Actuals YTD"
.Cells(1, 6) = "Variance YTD"
.Cells(1, 7) = "TO GO"
.Cells(1, 8) = IIf(Me.cboPeriod >= 1, "JAN ACT", "JAN ETC")
.Cells(1, 9) = IIf(Me.cboPeriod >= 2, "FEB ACT", "FEB ETC")
.Cells(1, 10) = IIf(Me.cboPeriod >= 3, "MAR ACT", "MAR ETC")
.Cells(1, 11) = IIf(Me.cboPeriod >= 4, "APR ACT", "APR ETC")
.Cells(1, 12) = IIf(Me.cboPeriod >= 5, "MAY ACT", "MAY ETC")
.Cells(1, 13) = IIf(Me.cboPeriod >= 6, "JUN ACT", "JUN ETC")
.Cells(1, 14) = IIf(Me.cboPeriod >= 7, "JUL ACT", "JUL ETC")
.Cells(1, 15) = IIf(Me.cboPeriod >= 8, "AUG ACT", "AUG ETC")
.Cells(1, 16) = IIf(Me.cboPeriod >= 9, "SEP ACT", "SEP ETC")
.Cells(1, 17) = IIf(Me.cboPeriod >= 10, "OCT ACT", "OCT ETC")
.Cells(1, 18) = IIf(Me.cboPeriod >= 11, "NOV ACT", "NOV ETC")
.Cells(1, 19) = IIf(Me.cboPeriod >= 12, "DEC ACT", "DEC ETC")
End With
'Format Row 1
With xlsheet
For Each Cell In xlsheet.Range("A1", "S1")
Cell.Font.Size = 10
Cell.Font.Name = "Arial"
Cell.Font.Bold = True
Cell.Interior.Color = conLightGray
Cell.HorizontalAlignment = xlHAlignCenter
Cell.WrapText = True
Next
.Cells(1, 2).HorizontalAlignment = xlHAlignLeft
.Columns("A").ColumnWidth = 9
.Columns("B").ColumnWidth = 39
.Columns("C:S").ColumnWidth = 9
.Rows(1).RowHeight = 25.5
End With
'Set Up Recordset for ITM Header data
Me.txtStatus = "Loading ITM Data"
Me.Repaint
Set qdf = CurrentDb.QueryDefs("qselSCCBhdr")
qdf.Parameters(0) = Me.cboResource
qdf.Parameters(1) = Me.cboPeriod
Set rstItms = qdf.OpenRecordset(dbOpenSnapshot, dbReadOnly)
'Be sure there are records to process
rstItms.MoveLast
rstItms.MoveFirst
lngItmCount = rstItms.RecordCount
If lngItmCount = 0 Then
MsgBox "No Data Found For This Report", vbInformation + vbOKOnly,
"Data Error"
GoTo Build_XL_Report_Exit
End If
'Load Header Data
xlsheet.Cells(2, 1).CopyFromRecordset rstItms
rstItms.Close
Set rstItms = Nothing
Set qdf = Nothing
'Format the ITM Name Cells
Me.txtStatus = "Formatting Headers"
Me.Repaint
With xlsheet
For Each Cell In xlsheet.Range("A2", "A" & Trim(str(lngItmCount + 2)))
Cell.Font.Size = 10
Cell.Font.Name = "Arial"
Cell.Font.Bold = True
Cell.Interior.Color = conLightGray
Cell.HorizontalAlignment = xlHAlignLeft
Cell.WrapText = False
Next
End With
'Merge the ITM Cells
For intX = 2 To lngItmCount + 2
strLeftRange = "A" & Trim(str(intX)) & ":B" & Trim(str(intX))
xlsheet.Range(strLeftRange).MergeCells = True
Next intX
'Size the Blank Row
xlsheet.Rows(lngItmCount + 3).RowHeight = 30
'Format Header Area and put in formulas
With xlsheet
For intX = 2 To lngItmCount + 1
strLeftRange = "C" & Trim(str(intX))
strRightRange = "S" & Trim(str(intX))
For Each Cell In xlsheet.Range(strLeftRange, strRightRange)
Cell.Font.Size = 10
Cell.Font.Name = "Arial"
Cell.Font.Bold = True
Cell.Interior.Color = conLightBlue
Cell.NumberFormat = "##,###,##0_);[Red](##,###,##0)"
Next
Next intX
'Do The Grand Total Row
strLeftRange = "C" & Trim(str(intX))
strRightRange = "S" & Trim(str(intX))
For Each Cell In xlsheet.Range(strLeftRange, strRightRange)
Cell.Font.Size = 10
Cell.Font.Name = "Arial"
Cell.Font.Bold = True
Cell.Interior.Color = conLightYellow
Cell.Formula = "= Grand"
Cell.NumberFormat = "##,###,##0_);[Red](##,###,##0)"
Next
End With
'Put Borders around the Header Area
With xlsheet.Range("A1", "S" & Trim(str(lngItmCount + 2)))
.Borders(xlTop).LineStyle = xlContinuous
.Borders(xlTop).Weight = xlThin
.Borders(xlBottom).LineStyle = xlContinuous
.Borders(xlBottom).Weight = xlThin
.Borders(xlLeft).LineStyle = xlContinuous
.Borders(xlLeft).Weight = xlThin
.Borders(xlRight).LineStyle = xlContinuous
.Borders(xlRight).Weight = xlThin
End With
'Add Total to ITM Names
For intX = 2 To lngItmCount + 1
xlsheet.Cells(intX, 1) = "Grand Total " & xlsheet.Cells(intX, 1)
Next intX
xlsheet.Cells(intX, 1) = "Grand Total " & _
Me.cboResource & " HOURS"
'Copy the Header Row to the top of the Data Area
xlsheet.Range("A1:S1").Copy _
Destination:=xlsheet.Range("A" & Trim(str(intX + 2)))
'Load the Data
Me.txtStatus = "Loading Detail Data"
Me.Repaint
Set qdf = CurrentDb.QueryDefs("qselSCCBrpt")
qdf.Parameters(0) = Me.cboResource
qdf.Parameters(1) = Me.cboPeriod
Set rstSCCB = qdf.OpenRecordset(dbOpenSnapshot, dbReadOnly)
xlsheet.Cells(intX + 3, 1).CopyFromRecordset rstSCCB
lngDetailCount = rstSCCB.RecordCount
rstSCCB.Close
Set rstSCCB = Nothing
Set qdf = Nothing
'Put in the SubTotals
Me.txtStatus = "Creating Subtotals"
Me.Repaint
lngFirstDataRow = intX + 3
lngLastDataRow = lngFirstDataRow + lngItmCount + lngDetailCount
With xlsheet
.Range(.Cells(lngFirstDataRow, 1), _
.Cells(lngLastDataRow, 19)).Subtotal groupBy:=1,
Function:=xlSum, _
totalList:=Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
16, 17, 18, 19)
End With
'Create Formulas and range names
For lngRowCount = lngFirstDataRow To lngLastDataRow
lngTotalPos = InStr(xlsheet.Cells(lngRowCount, 1), "Total")
If lngTotalPos = 0 Then 'Column S needs to be light yellow if not a
total row
xlsheet.Cells(lngRowCount, 5).Interior.Color = conLightYellow
xlsheet.Cells(lngRowCount, 6).Interior.Color = conLightYellow
Else
strCurrItm = Left(xlsheet.Cells(lngRowCount, 1), lngTotalPos - 2)
With xlsheet
.Range("C" & Trim(str(lngRowCount)) & ":S" & _
Trim(str(lngRowCount))).Name = strCurrItm
.Range("A" & Trim(str(lngRowCount)) & ":S" & _
Trim(str(lngRowCount))).Interior.Color = conLightGray
End With
End If
Next lngRowCount
'Clear the subtotals
xlsheet.Range("A:S").Copy
xlsheet.Range("A:S").PasteSpecial (xlPasteValues)
xlsheet.Range("A:S").RemoveSubtotal
xlsheet.Cells(1, 1).Select 'Removes the selection
'Set the Margins, Headers and Footers
Me.txtStatus = "Formating Worksheet"
Me.Repaint
strPrintArea = "A1:S" & Trim(str(lngLastDataRow))
strTitleRows = 1 & ":" & Trim(str(lngItmCount + 3))
With xlsheet.PageSetup
.Orientation = xlLandscape
.Zoom = False
.FitToPagesTall = False
.FitToPagesWide = 1
.CenterHeader = Me.txtCurrYear & " " & Me.cboResource _
& " Hours " & strMonth & " YTD"
.CenterFooter = "&F" & " " & "&D"
.RightFooter = "&R Page &P of &N"
.LeftMargin = xlApp.InchesToPoints(0)
.RightMargin = xlApp.InchesToPoints(0)
.TopMargin = xlApp.InchesToPoints(0.5)
.BottomMargin = xlApp.InchesToPoints(0.5)
.HeaderMargin = xlApp.InchesToPoints(0.25)
.FooterMargin = xlApp.InchesToPoints(0.25)
.PrintArea = strPrintArea
.PrintTitleRows = xlsheet.Rows(strTitleRows).Address
End With
'Format the Data Area
With xlsheet
strLeftRange = "A" & Trim(str(lngFirstDataRow))
strRightRange = "S" & Trim(str(lngLastDataRow))
For Each Cell In xlsheet.Range(strLeftRange, strRightRange)
Cell.Font.Size = 10
Cell.Font.Name = "Arial"
Cell.Font.Bold = True
Cell.NumberFormat = "##,###,##0_);[Red](##,###,##0)"
Next
End With
'Put Borders around the Data Area
With xlsheet.Range(strLeftRange, strRightRange)
.Borders(xlTop).LineStyle = xlContinuous
.Borders(xlTop).Weight = xlThin
.Borders(xlBottom).LineStyle = xlContinuous
.Borders(xlBottom).Weight = xlThin
.Borders(xlLeft).LineStyle = xlContinuous
.Borders(xlLeft).Weight = xlThin
.Borders(xlRight).LineStyle = xlContinuous
.Borders(xlRight).Weight = xlThin
End With
'Spreadsheet is complete - Save it
Me.txtStatus = "If Excel icon is Flashing, Click It"
Me.Repaint
blnSaveFile = False
Do Until blnSaveFile
'Build the File Name To Save
varGetFileName = Me.cboPeriod.Column(1) & _
IIf([Forms]![frmsccbrpt]![cboResource] = "SEL", _
" SCCB Report", " " & Me.cboResource & " Performance Report")
'Get the File Name To Save
varGetFileName = ahtCommonFileOpenSave(ahofn_overwriteprompt, _
"\\rsltx1-bm01\busmgmt\", "Excel Spreadsheets (*.xls) *.xls", , _
"xls", varGetFileName, "Save Report", , False)
If varGetFileName = "" Then 'User Clicked CANCEL
blnSaveFile = True
Exit Do
End If
'Parse the name to do a file search
varFileName = Right(varGetFileName, Len(varGetFileName) - _
InStrRev(varGetFileName, "\"))
varFolderName = Left(varGetFileName, InStrRev(varGetFileName, "\") -
1)
'See if the File already exisits
With xlApp.FileSearch
.NewSearch
.LookIn = varFolderName
.SearchSubFolders = False
.FileName = varFileName
If .Execute > 0 Then 'The file already exists
'Ask if the user wants to overwrite the old file
If MsgBox("The file " & varFileName & " already exists. " & _
"Do you want to replace the existing file?",
vbExclamation + vbYesNo, _
"Microsoft Excel") = vbYes Then
xlBook.SaveAs FileName:=varGetFileName
blnSaveFile = True
blnOkToShow = True
End If
Else
'The file is new, save it
xlBook.SaveAs FileName:=varGetFileName
blnSaveFile = True
blnOkToShow = True
End If
End With
Loop
'
'Time to Go
Build_XL_Report_Exit:
Me.txtStatus.Visible = False
Me.Repaint
xlBook.Close
xlApp.Quit
Set xlsheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
DoCmd.Hourglass (False)
'Show the Spreadsheet if we saved it
If blnOkToShow Then
Call Shell("excel " & Chr$(34) & varGetFileName & Chr$(34),
vbMaximizedFocus)
End If
Exit Sub
Build_XL_Report_ERR:
MsgBox (Err.Number & " - " & Err.Description)
GoTo Build_XL_Report_Exit
End Sub
