Private Sub FormatWeeklyJobStatus(sFileName)
Const xlDown = -4121
Const xlCellTypeLastCell = 11
Const xlThemeFontMinor = 2
Const xlPrintNoComments = -4142
Const xlPortrait = 1
Const xlPaperLegal = 5
Const xlPaperLetter = 1
Const xlOverThenDown = 2
Const xlPrintErrorsDisplayed = 0
Dim sPath As String
Dim sTemplateName As String
Dim lngRows As Long 'MUST be long
Dim ref As Reference
' 0 if Late Binding
' 1 if Reference to Excel set.
#Const ExcelRef = 0
#If ExcelRef = 0 Then ' Late binding
Dim appExcel As Object 'Excel Object
Dim wbkNew As Object 'Workbook Object
Dim wksNew As Object 'Sheet Object
Dim wbkTemplate As Object 'Workbook Object for Template
Set appExcel = CreateObject("Excel.Application")
' Remove the Excel reference if it is present - <=======
On Error Resume Next
Set ref = References!Excel
If Err.Number = 0 Then
References.Remove ref
ElseIf Err.Number <> 9 Then 'Subscript out of range meaning not reference not found
MsgBox Err.Description
Exit Sub
End If
' Use your own error handling label here
On Error GoTo FormatWeeklyJobStatus_Error
#Else
' a reference to MS Excel <version number> Object Library must be specified
Dim appExcel As Excel.Application 'Excel Object
Dim wbkNew As Excel.Workbook 'Workbook Object
Dim wksNew As Excel.Worksheet 'Sheet Object
Dim wbkTemplate As Excel.Workbook 'Workbook Object for Template
Set appExcel = New Excel.Application
#End If
On Error GoTo FormatWeeklyJobStatus_Error
sPath = DLookup("Database", "MsysObjects", "[Name] = 'tblJob'")
sPath = Left(sPath, InStrRev(sPath, "\"))
sTemplateName = sPath & "WeeklyJobStatusHeaders.xlsx"
Set wbkNew = appExcel.Workbooks.Open(sFileName)
Set wksNew = appExcel.Worksheets("qWeeklyJobStatusReportExcel")
'remove column names - some bug is preventing HasFieldNames argument from working on the export
If wksNew.Range("A1").Value = "ContractName" Then
appExcel.Rows("1:1").Select
appExcel.Rows("1:1").Delete
End If
' Insert 5 rows at top to make room for headers
With appExcel
.Rows("1:1").Select
.Selection.Insert Shift:=xlDown
.Selection.Insert Shift:=xlDown
.Selection.Insert Shift:=xlDown
.Selection.Insert Shift:=xlDown
.Selection.Insert Shift:=xlDown
' Get headers from template file
Set wbkTemplate = .Workbooks.Open(sTemplateName)
wbkTemplate.Activate
.Rows("1:5").Select
.Selection.Copy
' Paste into new Workbook.
wbkNew.Activate
.ActiveSheet.Paste
' Close template
.CutCopyMode = False 'clear clipboard to get rid of warning message
wbkTemplate.Close
'add job name
.Range("A5").Value = Me.cboJob.Column(3)
' Count rows in new Workbook.
.Selection.SpecialCells(xlCellTypeLastCell).Select
lngRows = .Selection.Row
'insert sum functions
'the reference style below uses the current position so we subtract the number of rows (lngRows)
'to get to the top and then add 5 to get past the headers
.Cells(lngRows + 1, 4).Select 'column D - Total plan pieces
.ActiveCell.FormulaR1C1 = "=SUM(R[" & -lngRows + 5 & "]C:R[" & -1 & "]C)"
.Cells(lngRows + 1, 5).Select 'column E - OFA pieces
.ActiveCell.FormulaR1C1 = "=SUM(R[" & -lngRows + 5 & "]C:R[" & -1 & "]C)"
.Cells(lngRows + 1, 6).Select 'column F - BFA pieces
.ActiveCell.FormulaR1C1 = "=SUM(R[" & -lngRows + 5 & "]C:R[" & -1 & "]C)"
.Cells(lngRows + 1, 7).Select 'column G - Issued to Shop pieces
.ActiveCell.FormulaR1C1 = "=SUM(R[" & -lngRows + 5 & "]C:R[" & -1 & "]C)"
.Cells(lngRows + 1, 9).Select 'column I - Cut Issue pieces
.ActiveCell.FormulaR1C1 = "=SUM(R[" & -lngRows + 5 & "]C:R[" & -1 & "]C)"
.Cells(lngRows + 1, 11).Select 'column K - Fitted pieces
.ActiveCell.FormulaR1C1 = "=SUM(R[" & -lngRows + 5 & "]C:R[" & -1 & "]C)"
.Cells(lngRows + 1, 12).Select 'column L - Welded pieces
.ActiveCell.FormulaR1C1 = "=SUM(R[" & -lngRows + 5 & "]C:R[" & -1 & "]C)"
.Cells(lngRows + 1, 13).Select 'column M - Shipped pieces
.ActiveCell.FormulaR1C1 = "=SUM(R[" & -lngRows + 5 & "]C:R[" & -1 & "]C)"
.Range("A" & lngRows + 1 & ":N" & lngRows + 1).Select
' Freeze panes
.Range("A6").Select
.ActiveWindow.FreezePanes = True
' Header should print on every page when in Print Preview
.ActiveSheet.PageSetup.PrintTitleRows = "$1:$5"
.ActiveSheet.PageSetup.PrintTitleColumns = ""
'format cells as numeric
.Cells.NumberFormat = "#,##0_);[Red](#,##0)"
' Set format for date columns
wksNew.Columns("H").NumberFormat = "d-mmm;@"
wksNew.Columns("J").NumberFormat = "d-mmm;@"
' Set font and size
.Cells.Select
With .Selection.Font
.Name = "Calibri"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
' Set page setup properties
.Columns("A:N").Select
.Selection.Columns.AutoFit
With .ActiveSheet.PageSetup
.PrintArea = "$A$1:$N$" & CStr(lngRows + 2)
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = appExcel.InchesToPoints(0.5)
.RightMargin = appExcel.InchesToPoints(0.5)
.TopMargin = appExcel.InchesToPoints(0.5)
.BottomMargin = appExcel.InchesToPoints(0.5)
.HeaderMargin = appExcel.InchesToPoints(0.5)
.FooterMargin = appExcel.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = True
.PrintComments = xlPrintNoComments
' .PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = IIf(lngRows > 44, xlPaperLegal, xlPaperLetter)
.FirstPageNumber = xlAutomatic
.Order = xlOverThenDown ' Change order to print all "page 1" before "page 2"
.BlackAndWhite = False
''.Zoom = 80 ' Shrink down a little
.Zoom = False ' Should not need both
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintErrors = xlPrintErrorsDisplayed
End With
End With
wbkNew.Save
FormatWeeklyJobStatus_Exit:
On Error Resume Next
' Required for cleanup.
wbkNew.Close
Exit Sub
FormatWeeklyJobStatus_Error:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure FormatWeeklyJobStatus of VBA Document Form_frmReports"
End Select
Resume FormatWeeklyJobStatus_Exit
End Sub
