Here is an example that does a lot of different things in an Excel spreadsheet.
Sub Build_XL_Report(strOutPut As String)
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 varGetFileName As Variant 'File Name with Full Path
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 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 blnExcelWasNotRunning As Boolean
Dim strDefaultDir 'Where to save spreadsheet
Dim strDefaultFileName 'Name to Save as
Dim lngFlags As Long 'Flags for common dialog
Dim strFilter As String 'File Display for Common Dialog
Dim strCurrMonth As String 'To create directory name for save
Dim strCurrYear As String 'To create directory name for save
Dim blnStopXl As Boolean 'Leave Open for Spreadsheet Version
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, 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
'Set up default path and file
strCurrYear = Me.txtCurrYear
strCurrMonth = Me.cboPeriod.Column(1)
strDefaultDir = "\\rsltx1-bm01\busmgmt\Vought " & strCurrYear & "\" &
strCurrYear _
& " Actuals\" & strCurrMonth & "\"
strDefaultFileName = Me.cboPeriod.Column(1) & _
IIf([Forms]![frmsccbrpt]![cboResource] = "SEL", _
" SCCB Report", " " & Me.cboResource & " Performance Report") &
".xls"
'Set filter to show only Excel spreadsheets
strFilter = ahtAddFilterItem(strFilter, "Excel Files (*.xls)")
'Flags Hides the Read Only Check and Only allow existing files
lngFlags = ahtOFN_HIDEREADONLY Or ahtOFN_OVERWRITEPROMPT
'Call the Open File Dialog
varGetFileName = ahtCommonFileOpenSave( _
OpenFile:=False, _
InitialDir:=strDefaultDir, _
Filter:=strFilter, _
Filename:=strDefaultFileName, _
Flags:=lngFlags, _
DialogTitle:="Save Report")
If varGetFileName <> "" Then
xlBook.SaveAs Filename:=varGetFileName
Select Case strOutPut
Case "Print"
blnStopXl = True
xlSheet.PrintOut Copies:=1, Collate:=True
Case "PreView"
blnStopXl = True
xlApp.DisplayAlerts = True
xlApp.Interactive = True
xlApp.ScreenUpdating = True
xlApp.Visible = True
xlApp.WindowState = xlMaximized
xlSheet.PrintPreview
xlApp.Visible = False
Case "XL"
blnStopXl = False
xlApp.DisplayAlerts = True
xlApp.Interactive = True
xlApp.ScreenUpdating = True
xlApp.WindowState = xlMaximized
xlApp.Visible = True
End Select
End If
'Time to Go
Build_XL_Report_Exit:
Me.txtStatus.Visible = False
Me.Repaint
If blnStopXl Then
xlBook.Close
If blnExcelWasNotRunning = True Then
xlApp.Quit
Else
xlApp.DisplayAlerts = True
xlApp.Interactive = True
xlApp.ScreenUpdating = True
End If
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
End If
DoCmd.Hourglass (False)
Exit Sub
Build_XL_Report_ERR:
MsgBox (Err.Number & " - " & Err.Description)
blnStopXl = True
GoTo Build_XL_Report_Exit
End Sub
