Private Sub cmdExportRawDataToExcel_Click()
On Error Resume Next
'DoCmd.OutputTo acOutputQuery, "YourQueryHere", acFormatXLS, , True
Dim oApp As Excel.Application
Dim oWT As Excel.Workbook
Dim oWS As Excel.Worksheet
Dim lastRow As Long
Dim lStartOfDataList As Long
Dim lEndOfDatList As Long
DoCmd.RunCommand acCmdSaveRecord
Application.Echo False
Set oApp = GetObject("Excel.Application")
If Err.Number <> 0 Then Set oApp = CreateObject("Excel.Application")
With oApp
.Visible = True
.Workbooks.Close
On Error GoTo 0
.Workbooks.Add
.Workbooks(1).Activate
Set oWT = .ActiveWorkbook
Set oWS = oWT.ActiveSheet
.ScreenUpdating = False
.DisplayAlerts = False
'set orientation to landscape
oWS.PageSetup.Orientation = xlLandscape
'lets do the header
oWS.PageSetup.CenterHeader = "&""Arial,Bold""&10" & "YOUR TITLE HERE"
'now the footer
' oWS.PageSetup.CenterFooter = " = Page " & "[Page]" & " of " & "[Pages]"
' oWS.PageSetup.RightFooter = " = " & "[Date]" & ""
oWS.PageSetup.CenterFooter = "Page &P of &N"
oWS.PageSetup.RightFooter = "Printed &D &T"
oWS.PageSetup.LeftFooter = "EXCEL FOOTER"
oWS.PageSetup.LeftMargin = oApp.InchesToPoints(0.75)
oWS.PageSetup.RightMargin = oApp.InchesToPoints(0.75)
oWS.PageSetup.TopMargin = oApp.InchesToPoints(1)
oWS.PageSetup.BottomMargin = oApp.InchesToPoints(1)
oWS.PageSetup.PaperSize = xlPaperLegal
'force one fit one page wide
oWS.PageSetup.Zoom = False
oWS.PageSetup.FitToPagesWide = 1
oWS.PageSetup.FitToPagesTall = False
oWS.PageSetup.PrintTitleRows = oWS.Range("A1", oWS.Range("A1").End(xlUp)).EntireRow.Address
'now lets paste the exception list
DoCmd.OpenQuery "MedicalWriteOffs"
DoCmd.RunCommand acCmdSelectAllRecords
DoCmd.RunCommand acCmdCopy
Set oWS = oWT.ActiveSheet
oWS.Range("A1").Activate
oWS.Paste
DoCmd.OpenQuery "YourQueryHere"
DoCmd.RunCommand acCmdSelectRecord 'Minimize the risk of message: "You have copied a large amount of data..."
DoCmd.RunCommand acCmdCopy
DoCmd.Close acQuery, "YourQueryHere", acSaveNo
'add the totals
'we need to add a total now
lastRow = oWS.Range("A" & oWS.Rows.Count).End(xlUp).Row
oWS.Range("A" & lastRow + 1).Activate
oWS.Range("A" & lastRow + 1) = "TOTAL:"
oWS.Range("A" & lastRow + 1).Font.Bold = True
oWS.Range("D" & lastRow + 1) = .WorksheetFunction.Sum(oWS.Range("D2:D" & lastRow))
oWS.Range("D" & lastRow + 1).Font.Bold = True
oWS.Range("E" & lastRow + 1) = .WorksheetFunction.Sum(oWS.Range("E2:E" & lastRow))
oWS.Range("E" & lastRow + 1).Font.Bold = True
oWS.Range("D2:E" & lastRow + 1).NumberFormat = "$#,##0.00"
oWS.Range("A" & lastRow & ":K" & lastRow).Borders(xlEdgeBottom).LineStyle = xlContinuous
oWS.Range("A" & lastRow & ":K" & lastRow).Borders(xlEdgeBottom).Weight = xlThick
oWS.Range("A" & lastRow & ":K" & lastRow).Borders(xlEdgeBottom).ColorIndex = xlAutomatic
'now to autofit columns
lastRow = oWS.Range("A" & oWS.Rows.Count).End(xlUp).Row
lEndOfDatList = lastRow
oWS.Range("A1:J" & lastRow).Select
.Selection.Font.Size = 10
.Selection.WrapText = False
oWS.Range("A1:K" & lastRow).Columns.AutoFit
oWT.Worksheets("Sheet1").Name = "SHEET_NAME"
.ScreenUpdating = True
.DisplayAlerts = True
End With
Application.Echo True
oApp.Visible = True
AppActivate "Microsoft Excel"
Set oApp = Nothing
End Sub