Function fcnExportReport()
Dim strWorksheet As String
Dim strWorksheetPath As String
Dim appExcel As Excel.Application
Dim sht As Excel.Worksheet
Dim wkb As Excel.Workbook
Dim rng As Excel.Range
Dim strTable As String
Dim strRange As String
Dim strSaveName As String
Dim strPrompt As String
Dim strTitle As String
Dim strDefault As String
Dim intRecordNumber As Integer
Dim dteInitialDate(8) As String
Dim strChar(25) As String
intRecordNumber = DCount("*", "[tblRepIPAR]") + 2 'the next number cell after the last transfered record
dteInitialDate(0) = [Forms]![frmReport].txtStartDate
'Open the newly created worksheet and insert title material:
Set appExcel = GetObject(, "Excel.Application")
appExcel.Workbooks.Open (strSaveName)
Set wkb = appExcel.ActiveWorkbook
Set sht = appExcel.ActiveSheet
sht.Activate
With sht
'Remove the "ID" column
.Columns("A:A").Delete Shift:=xlToLeft
.Columns("P:P").Delete Shift:=xlToLeft
'convert negative numbers into "n/a"
For n = 3 To 11
For m = 2 To (intRecordNumber - 1)
If .Range((strChar(n) & m)).Formula < 0 Then
.Range((strChar(n) & m)).Formula = "n/a"
End If
Next
Next
'Format the C column
'Range("C2":"C" & (intRecordNumber - 1)).
For m = 2 To (intRecordNumber - 1)
strCell1 = .Range((strChar(2) & m)).Formula
strCell2 = Left(strCell1, 1) & "." & mid(strCell1, 2, 1) & "." & Right(strCell1, 1)
.Range((strChar(2) & m)).Formula = strCell2
Next
'Add the total calculations and count
.Range(strChar(0) & intRecordNumber).Formula = "Total Sent"
.Range(strChar(0) & (intRecordNumber + 1)).Formula = "Total Sending "
For o = 3 To 11
strFormula1 = "= SUM(" & strChar(o) & "2:" & strChar(o) & (intRecordNumber - 1) & ")"
strFormula2 = "= COUNTIF(" & strChar(o) & "2:" & strChar(o) & (intRecordNumber - 1) & ", " & Chr(34) & "> 0" & Chr(34) & ")"
strCell1 = strChar(o) & intRecordNumber
strCell2 = strChar(o) & (intRecordNumber + 1)
.Range(strCell1).Formula = strFormula1
.Range(strCell2).Formula = strFormula2
Next
'''''''''''''''''''''''''formatting''''''''''''''''''''''''''
'Apply the Arial 10 pt font to the entire worksheet:
.Range("A:O").Font.Name = "Arial"
.Range("A:O").Font.Size = 10
.PageSetup.Orientation = xlLandscape
'change column Widths
.Range("A:A").ColumnWidth = 45
.Range("B:B").ColumnWidth = 10
.Range("C:C").ColumnWidth = 10
.Range("D:L").ColumnWidth = 4
.Range("M:M").ColumnWidth = 14
.Range("N:N").ColumnWidth = 93
.Range("O:O").ColumnWidth = 14
'format the column headings
With .Range("A1:O1")
.Font.Bold = True
End With
.Range("D1:L1").Orientation = xlUpward
.Range("D1:L1").NumberFormat = "[$-409]d-mmm-yy;@"
.Range("A1:O1").HorizontalAlignment = xlCenter
.Range("A1").Formula = "Ships Configured for DS"
.Range("A1:P1").RowHeight = 55
'center B thru M.
.Range("B:M").HorizontalAlignment = xlCenter
'change week titles
.Range("D1").Formula = dteInitialDate(0)
.Range("E1").Formula = dteInitialDate(1)
.Range("F1").Formula = dteInitialDate(2)
.Range("G1").Formula = dteInitialDate(3)
.Range("H1").Formula = dteInitialDate(4)
.Range("I1").Formula = dteInitialDate(5)
.Range("J1").Formula = dteInitialDate(6)
.Range("K1").Formula = dteInitialDate(7)
.Range("L1").Formula = dteInitialDate(8)
.Range("N1").Formula = "Known Issues"
'put borders around the main data
strCell1 = strChar(14) & (intRecordNumber - 1)
With .Range("A1:" & strCell1).Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
'put borders around the summary lines
strCell1 = strChar(3) & intRecordNumber
strCell2 = strChar(11) & (intRecordNumber + 1)
With .Range(strCell1 & ":" & strCell2)
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
.Borders.ColorIndex = 1
.Font.Bold = True
End With
'put borders around the data calculations
strCell1 = strChar(0) & (intRecordNumber)
strCell2 = strChar(2) & (intRecordNumber + 8)
With .Range(strCell1 & ":" & strCell2)
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
.Borders.ColorIndex = 1
.Font.Bold = True
.Font.Color = -65536
End With
.Range("D" & intRecordNumber & ":L" & intRecordNumber).Font.Color = -6750208
.Range("D" & intRecordNumber + 1 & ":L" & intRecordNumber + 1).Font.Color = -65281
.Range("A" & intRecordNumber + 7 & ":C" & intRecordNumber + 8).Font.Color = -16777088
'conditional Formatting
'''''''''''GREEN
.Range("D2:L" & intRecordNumber - 1).FormatConditions.Add Type:=xlCellValue, Operator:=xlBetween, _
Formula1:="=1", Formula2:="=8"
.Range("D2:L" & intRecordNumber - 1).FormatConditions(.Range("D2:L" & intRecordNumber - 1).FormatConditions.Count).SetFirstPriority
With .Range("D2:L" & intRecordNumber - 1).FormatConditions(1).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65280
.TintAndShade = 0
.PatternTintAndShade = 0
End With
.Range("D2:L" & intRecordNumber - 1).FormatConditions(1).StopIfTrue = True
'''''''''''''RED
.Range("D2:L" & intRecordNumber - 1).FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=0"
.Range("D2:L" & intRecordNumber - 1).FormatConditions(.Range("D2:L" & intRecordNumber - 1).FormatConditions.Count).SetFirstPriority
With .Range("D2:L" & intRecordNumber - 1).FormatConditions(1).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
.Range("D2:L" & intRecordNumber - 1).FormatConditions(1).StopIfTrue = True
''''''''''''ORANGE
.Range("D2:L" & intRecordNumber - 1).FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="= ""n/a"""
.Range("D2:L" & intRecordNumber - 1).FormatConditions(.Range("D2:L" & intRecordNumber - 1).FormatConditions.Count).SetFirstPriority
With .Range("D2:L" & intRecordNumber - 1).FormatConditions(1).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
.Range("D2:L" & intRecordNumber - 1).FormatConditions(1).StopIfTrue = True
End With
ErrorHandlerExit:
Exit Function
ErrorHandler:
If Err = 429 Then
'Excel is not running; open Excel with CreateObject:
Set appExcel = CreateObject("Excel.Application")
Resume Next
Else
MsgBox "Error No: " & Err.Number _
& "; Description: " & Err.Description
Resume ErrorHandlerExit
End If
End Function