Code:
Private Sub cmdExportReports_Click()
' This procedure exports the reports to an Excel file.
Dim NewWBName As String
Dim WBName As String
Dim DTAddress As String
Dim strObjectType As String
Dim strObjectName As String
Dim strSheetName As String
Dim strFileName As String
On Error GoTo ErrorHandler
DoCmd.Hourglass True
DTAddress = CreateObject("WScript.Shell").SpecialFolders("Desktop") & ""
WBName = "CRA_Suspense_Reports_" & Format(Now, "yyyymmdd_hhmmss") & ".xlsx"
NewWBName = DTAddress & WBName
ExportToExcel "qry_Report_by_Error_With_Percentages", "By Error", NewWBName
AppendToExcel "qry_Report_By_Files", "By Files", NewWBName
AppendToExcel "qry_Report_Aging_By_Month_Final", "Aging By Month", NewWBName
AppendToExcel "qry_Report_By_CRA", "By CRA", NewWBName
AppendToExcel "qry_Report_Command_Account_Final", "Command Accounts", NewWBName
AppendToExcel "qry_Report_Summary_Final", "Summary", NewWBName
AppendToExcel "qry_Report_Detail", "Detail", NewWBName
DoCmd.Hourglass False
MsgBox "The report has been created on the desktop " & WBName
Exit Sub
ErrorHandler:
' Display error information.
MsgBox "Error number " & Err.Number & ": " & Err.Description
' Resume following occurrence of error.
Resume Next
End Sub
Public Sub ExportToExcel(strObjectName As String, strSheetName As String, strFileName As String)
' This procedure exports the first report and saves the orginal Excel workbook for all of the
' rest of the reports to be sent.
Dim intCount As Integer
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim XL As Excel.Application
Dim WB As Excel.Workbook
Dim WS As Excel.Worksheet
Dim LastRow As Long
Application.Echo False
On Error GoTo ExportToExcel_Err
Set db = CurrentDb
Set rst = db.OpenRecordset(strObjectName)
If rst.RecordCount = 0 Then
MsgBox "No records to be exported."
Else
On Error Resume Next
Set XL = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set XL = CreateObject("Excel.Application")
End If
Err.Clear
On Error GoTo ExportToExcel_Err
Set WB = XL.Workbooks.Add
XL.Visible = False
Set WS = WB.Worksheets("Sheet1")
If Len(strSheetName) > 0 Then
WS.Name = Left(strSheetName, 31)
End If
WS.Range("A1").Select
Do Until intCount = rst.Fields.Count
XL.ActiveCell = rst.Fields(intCount).Name
XL.ActiveCell.Offset(0, 1).Select
intCount = intCount + 1
Loop
rst.MoveFirst
WS.Range("A2").CopyFromRecordset rst
With XL
.Range("A1").Select
.Range(.Selection, .Selection.End(xlToRight)).Select
.Selection.Interior.Pattern = xlSolid
.Selection.Interior.PatternColorIndex = xlAutomatic
.Selection.Interior.TintAndShade = -0.25
.Selection.HorizontalAlignment = xlCenter
.Selection.Font.Bold = True
.Cells.EntireColumn.AutoFit
' .Visible = True
End With
LastRow = LastCell(ActiveSheet).Row
If strSheetName = "By Error" Then
Columns("B:B").Select
Selection.Style = "Currency"
Columns("C:C").Select
Selection.NumberFormat = "0.00%"
Range("B" & LastRow + 1).Select
ActiveCell.Formula = "=sum(B2:B" & LastRow & ")"
Selection.Font.Bold = True
Range("C" & LastRow + 1).Select
ActiveCell.Formula = "=sum(C2:C" & LastRow & ")"
Selection.Font.Bold = True
XL.Cells.EntireColumn.AutoFit
XL.Range("A1").Select
End If
WB.SaveAs strFileName
WB.Close
rst.Close
Set rst = Nothing
End If
Exit Sub
ExportToExcel_Err:
DoCmd.SetWarnings True
MsgBox Err.Description, vbExclamation, Err.Number
Resume Next
End Sub
Public Sub AppendToExcel(strObjectName As String, strSheetName As String, strFileName As String)
' This procedure appends the rest of the reports into the first created Excel file.
Dim rst As DAO.Recordset
Dim XL As Excel.Application
Dim WB As Excel.Workbook
Dim WS As Excel.Worksheet
Dim intCount As Integer
On Error GoTo ErrorHandler
Application.Echo False
Set rst = CurrentDb.OpenRecordset(strObjectName)
If rst.RecordCount = 0 Then
MsgBox "No records to be exported."
Else
On Error Resume Next
Set XL = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set XL = CreateObject("Excel.Application")
End If
Err.Clear
XL.Visible = False
Set WB = XL.Workbooks.Open(strFileName)
Set WS = WB.Sheets.Add
WS.Name = Left(strSheetName, 31)
WS.Range("A1").Select
Do Until intCount = rst.Fields.Count
XL.ActiveCell = rst.Fields(intCount).Name
XL.ActiveCell.Offset(0, 1).Select
intCount = intCount + 1
Loop
rst.MoveFirst
WS.Range("A2").CopyFromRecordset rst
rst.Close
Set rst = Nothing
With XL
.Range("A1").Select
.Range(.Selection, .Selection.End(xlToRight)).Select
.Selection.Interior.Pattern = xlSolid
.Selection.Interior.PatternColorIndex = xlAutomatic
.Selection.Interior.TintAndShade = -0.25
.Selection.HorizontalAlignment = xlCenter
.Selection.Font.Bold = True
.Cells.EntireRow.AutoFit
.ActiveSheet.Cells.EntireColumn.AutoFit
End With
LastRow = LastCell(ActiveSheet).Row
If strSheetName = "By Files" Then
Columns("E:E").Select
Selection.Style = "Currency"
Range("E" & LastRow + 1).Select
ActiveCell.Formula = "=sum(E2:E" & LastRow & ")"
Selection.Font.Bold = True
ElseIf strSheetName = "Aging By Month" Then
Columns("C:C").Select
Selection.Style = "Currency"
Columns("D:D").Select
Selection.NumberFormat = "0.00%"
Range("C" & LastRow + 1).Select
Selection.Font.Bold = True
ActiveCell.Formula = "=sum(C2:C" & LastRow & ")"
Selection.Font.Bold = True
Range("D" & LastRow + 1).Select
ActiveCell.Formula = "=sum(D2:D" & LastRow & ")"
Selection.Font.Bold = True
Columns("E:F").Select
Selection.Delete Shift:=xlToLeft
ElseIf strSheetName = "By CRA" Then
Columns("C:C").Select
Selection.Style = "Currency"
Range("C" & LastRow + 1).Select
ActiveCell.Formula = "=sum(C2:C" & LastRow & ")"
Selection.Font.Bold = True
ElseIf strSheetName = "Command Accounts" Then
Columns("B:B").Select
Selection.Style = "Currency"
Columns("C:C").Select
Selection.NumberFormat = "0.00%"
Range("B" & LastRow + 1).Select
ActiveCell.Formula = "=sum(B2:B" & LastRow & ")"
Selection.Font.Bold = True
Range("C" & LastRow + 1).Select
ActiveCell.Formula = "=sum(C2:C" & LastRow & ")"
Selection.Font.Bold = True
ElseIf strSheetName = "Summary" Then
Columns("B:B").Select
Selection.Style = "Currency"
Columns("E:E").Select
Selection.NumberFormat = "0.00%"
Range("B" & LastRow + 1).Select
ActiveCell.Formula = "=sum(B2:B" & LastRow & ")"
Selection.Font.Bold = True
Range("C" & LastRow + 1).Select
ActiveCell.Formula = "=sum(C2:C" & LastRow & ")"
Selection.Font.Bold = True
Range("D" & LastRow + 1).Select
ActiveCell.Formula = "=sum(D2:D" & LastRow & ")"
Selection.Font.Bold = True
Range("E" & LastRow + 1).Select
ActiveCell.Formula = "=sum(E2:E" & LastRow & ")"
Selection.Font.Bold = True
End If
XL.Cells.EntireColumn.AutoFit
WS.Range("A1").Select
WB.Close True
WB = Nothing
XL.Close
Set XL = Nothing
End If
Exit Sub
ErrorHandler:
' Display error information.
MsgBox "Error number " & Err.Number & ": " & Err.Description
' Resume following occurrence of error.
Resume Next
End Sub