Code:
Private Sub Command7_Click()
Dim strWhere As String
strWhere = "[LEVELCODE1]=" & Chr(34) & Me.Combo0 & Chr(34)
DoCmd.OpenReport ReportName:="HOSURaw Query 2", _
View:=acViewPreview, WhereCondition:=strWhere
DoCmd.OpenReport ReportName:="HOSURaw Query 2 Excel", _
View:=acViewPreview, WhereCondition:=strWhere
Dim strpath As String
Dim strfilename As String
Dim queryname As String
Dim fieldname As String
Set db = CurrentDb()
fieldname = Me.Combo0
strpath = "C:\My Documents\Forecasting\HOSU Reporting\"
strfilename = "HOSU" & "_" & Format(Date, "ddmmyyyy") & "_" & fieldname & ".pdf"
strfilename2 = "HOSU" & "_" & Format(Date, "ddmmyyyy") & "_" & fieldname & ".xls"
DoCmd.OutputTo acOutputReport, "HOSURaw Query 2", ".pdf", strpath & strfilename, False
DoCmd.OutputTo acOutputReport, "HOSURaw Query 2 Excel", ".xls", strpath & strfilename2, False
EmailYesNo = MsgBox("Would you like to email the report in PDF?", vbYesNo, "Email?")
If EmailYesNo = vbYes Then
Dim email As String
email = email
DoCmd.SendObject _
acSendReport, _
"HOSURaw Query 2", _
acFormatPDF, _
email, _
, _
, _
"HOSU" & "_" & Format(Date, "ddmmyyyy") & "_" & fieldname, _
"Please find attached your latest HOSU Report, Thanks, Ian", _
False
Else
MsgBox "Reports Created and Saved"
End If
DoCmd.Close acReport, "HOSURaw Query 2"
DoCmd.Close acReport, "HOSURaw Query 2 Excel"
Dim objXL As Object
Dim strXls As String
strXls = strpath & strfilename2
Set objXL = CreateObject("Excel.Application")
With objXL
.Visible = True
.Workbooks.Open (strXls)
.Range("A1").Select
.Selection.Cut
.Range("P2").Select
.Activesheet.Paste
.Rows("1:1").Select
.Selection.Delete Shift:=xlUp
.Columns("I:O").Select
.Selection.NumberFormat = "$#,##0_);[Red]($#,##0)"
.Columns("A:A").Select
.Application.CutCopyMode = False
.Selection.Delete Shift:=xlToLeft
.Range("A1").Select
.ActiveCell.FormulaR1C1 = "'Sub-Unit"
.Range("E1").Select
.ActiveCell.FormulaR1C1 = "'Level 5"
.Range("D1").Select
.ActiveCell.FormulaR1C1 = "'Level 4"
.Range("C1").Select
.ActiveCell.FormulaR1C1 = "'Level 3"
.Range("B1").Select
.ActiveCell.FormulaR1C1 = "'Level 2"
.Range("F1").Select
.ActiveCell.FormulaR1C1 = "'Level 4 Description"
.Range("G1").Select
.ActiveCell.FormulaR1C1 = "'Level 5 Description"
.Range("H1").Select
.ActiveCell.FormulaR1C1 = "'Original Budget"
.Range("I1").Select
.ActiveCell.FormulaR1C1 = "'Full Year Current Forecast"
.Range("J1").Select
.ActiveCell.FormulaR1C1 = "'Current Forecast to Date"
.Range("K1").Select
.ActiveCell.FormulaR1C1 = "'Actual to Date"
.Range("L1").Select
.ActiveCell.FormulaR1C1 = "'Commitment"
.Range("M1").Select
.ActiveCell.FormulaR1C1 = "'Under / (Over) Spend to Date"
.Range("N1").Select
.ActiveCell.FormulaR1C1 = "'Balance available (Full Year Current Forecast - Actual to Date)"
.cells.Select
.Selection.Subtotal GroupBy:=2, Function:=1, TotalList:=Array(8, 9, 10, 11, 12, 13, 14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
.Columns("I:I").Select
.Selection.TextToColumns Destination:=Range("I1"), DataType:=xlFixedWidth, FieldInfo:=Array(0, 1), TrailingMinusNumbers:=True
.ActiveWorkbook.Save
End With
objXL.Workbooks.Close
objXL.Application.Quit
Set objActiveWkb = Nothing: Set objXL = Nothing
End Sub