Question Excel - Late binding

[ChrisO]

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:-

[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:-

[color=green]' Delete the Header appended from the Query result.[/color]
.Rows(1).Delete

Then the column calculations became:-

[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:-

GetObject(strFileName).Close

So I changed it to:-

GetObject(strFileName).Close SaveChanges:=False

So the last test code, which used my Class constants, was as follows:-

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.

 

[ChrisO]

wksNew is the correct pointer for Range because it has already been Set as in:-

Set wksNew = appExcel.Worksheets("qWeeklyJobStatusReportExcel")

So, if the Header has already been deleted, then:-

wksNew.Range("E" & lngRows) = "=SUM(E6:E" & lngRows - 1 & ")"

else increase lngRows by one.

lngRows as Long because the number of rows might cause an overflow.

Chris.

 

[Pat Hartman]

Thanks. I'll try it tomorrow at the office. I can't really test at home because the app is linked to Timberline tables in a Pervasive database and I don't have the database engine installed at home or on my laptop.