ChrisO
Registered User.
- Local time
- Today, 19:45
- Joined
- Apr 30, 2003
- Messages
- 3,202
Pat.
The code I posted in post #18 worked when tested and it also produced black positive numbers and red negative numbers.
I don’t think you want to sum columns H and J because they are formatted as dates as in:-
I also got the first exported row as the header which was removed with:-
Then the column calculations became:-
When Excel was opened it calculated correctly but that made the sheet ‘dirty’ and required the end user to say if they wanted to save the changes when it was closed with:-
So I changed it to:-
So the last test code, which used my Class constants, was as follows:-
The above code is in the attachment.
If that doesn’t work can you please post a small amount of test data, Access 2003 back end and Query, and I’ll test it with that.
Chris.
The code I posted in post #18 worked when tested and it also produced black positive numbers and red negative numbers.
I don’t think you want to sum columns H and J because they are formatted as dates as in:-
Code:
[color=green]' Set format for date columns[/color]
wksNew.Columns("H").NumberFormat = "d-mmm;@"
wksNew.Columns("J").NumberFormat = "d-mmm;@"
I also got the first exported row as the header which was removed with:-
Code:
[color=green]' Delete the Header appended from the Query result.[/color]
.Rows(1).Delete
Then the column calculations became:-
Code:
[color=green]' Set calculated cells formula.[/color]
strCol = "I"
.Cells(lngRows, strCol).Value = "=SUM(" & strCol & conHeaderRows + 1 & ":" & strCol & lngRows - 1 & ")"
When Excel was opened it calculated correctly but that made the sheet ‘dirty’ and required the end user to say if they wanted to save the changes when it was closed with:-
Code:
GetObject(strFileName).Close
Code:
GetObject(strFileName).Close SaveChanges:=False
So the last test code, which used my Class constants, was as follows:-
Code:
Option Explicit
Option Compare Text
Public con As New clsConstants
Sub TestIt()
Dim lngError As Long
Dim strFileName As String
Dim strQueryName As String
strFileName = "C:\NewWeeklyJobStatusHeaders.xls"
strQueryName = "qWeeklyJobStatusReportExcel"
On Error Resume Next
' Remove any instance of Excel which may have strFileName already open.
' This can happen if the end user minimisers Excel and runs the code a second time.
' Since the application has calculated cells, let's avoid the message to save.
GetObject(strFileName).Close SaveChanges:=False
' Kill any pre-existing file called strFileName, we will create a new one.
Kill strFileName
On Error GoTo 0
DoCmd.TransferSpreadsheet acExport, con.Excel.acSpreadsheetTypeExcel9, strQueryName, strFileName, False
' Call the function and return the error code.
lngError = FormatWeeklyJobStatus(strFileName)
If lngError Then
MsgBox "Error " & lngError & " (" & Error(lngError) & ") in procedure FormatWeeklyJobStatus"
Else
' Open the new instance for display to the end user, if required.
With CreateObject("Excel.Application")
.Workbooks.Open strFileName
.Visible = True
End With
End If
End Sub
Private Function FormatWeeklyJobStatus(sFileName) As Long
Dim appExcel As Object
Dim wbkNew As Object
Dim wbkTemplate As Object
Dim wksNew As Object
Dim sPath As String
Dim sTemplateName As String
Dim lngRows As Long
Dim strCol As String
' Since we use this throughout the procedure it should be a constant.
Const conHeaderRows As Long = 5
On Error GoTo FormatWeeklyJobStatus_Error
sPath = DLookup("Database", "MsysObjects", "[Name] = 'tblJob'")
sPath = Left(sPath, InStrRev(sPath, "\"))
sTemplateName = sPath & "WeeklyJobStatusHeaders.xls"
Set appExcel = CreateObject("Excel.Application")
Set wbkNew = appExcel.Workbooks.Open(sFileName)
Set wksNew = appExcel.Worksheets("qWeeklyJobStatusReportExcel")
With appExcel
' Delete the Header appended from the Query result.
.Rows(1).Delete
' Insert conHeaderRows at top to make room for headers
.Rows("1:1").Select
For lngRows = 1 To conHeaderRows
.Selection.Insert Shift:=con.Excel.xlDown
Next lngRows
' Get headers from template file
Set wbkTemplate = .Workbooks.Open(sTemplateName)
.Rows("1:" & conHeaderRows).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 SaveChanges:=False
' Count rows in new Workbook
.Selection.SpecialCells(con.Excel.xlCellTypeLastCell).Select
lngRows = .Selection.Row
' Freeze panes
.Range("A" & conHeaderRows + 1).Select
.ActiveWindow.FreezePanes = True
' Autofit first column
.Columns("A:A").EntireColumn.AutoFit
' Header should print on every page when in Print Preview
.ActiveSheet.PageSetup.PrintTitleRows = "$1:$" & conHeaderRows
.ActiveSheet.PageSetup.PrintTitleColumns = ""
' Set format for numbers
.Cells.NumberFormat = "#,##0_);[Red](#,##0)"
' Set format for date columns
wksNew.Columns("H").NumberFormat = "d-mmm;@"
wksNew.Columns("J").NumberFormat = "d-mmm;@"
' Set calculated cells formula.
strCol = "I"
.Cells(lngRows, strCol).Value = "=SUM(" & strCol & conHeaderRows + 1 & ":" & strCol & lngRows - 1 & ")"
strCol = "K"
.Cells(lngRows, strCol).Value = "=SUM(" & strCol & conHeaderRows + 1 & ":" & strCol & lngRows - 1 & ")"
' Set font and size
.Cells.Select
With .Selection.Font
.Name = "Calibri"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = con.Excel.xlUnderlineStyleNone
' .TintAndShade = 0 ' Don't know about this one.
' .ThemeFont = con.EXCEL.xlThemeFontMinor ' Can't test this in XP.
End With
' Set page setup properties
.Columns("A:N").Select
.Selection.Columns.AutoFit
With .ActiveSheet.PageSetup
' I don't know the intention here...
' .PrintArea = "$A:$N"
' .PrintArea = ""
.PrintArea = "$A$1:$N$" & CStr(lngRows)
.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 = con.Excel.xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = con.Excel.xlPortrait
.Draft = False
.PaperSize = IIf(lngRows > 44, con.Excel.xlPaperLegal, con.Excel.xlPaperLetter)
.FirstPageNumber = con.Excel.xlAutomatic
.Order = con.Excel.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 = con.Excel.xlPrintErrorsDisplayed
End With
End With
FormatWeeklyJobStatus_Exit:
On Error Resume Next
' Required for cleanup.
wbkNew.Close SaveChanges:=True
Exit Function
FormatWeeklyJobStatus_Error:
FormatWeeklyJobStatus = Err.Number ' Save the error.
Resume FormatWeeklyJobStatus_Exit ' Clear the error and cleanup.
End Function
The above code is in the attachment.
If that doesn’t work can you please post a small amount of test data, Access 2003 back end and Query, and I’ll test it with that.
Chris.