Late Binding: extract Access to Excel with formatting

[roelandwatteeuw]

Hi all

Situation:
I'm extracting an Access query to Excel with VBA.
In this excel, I let VBA do a few things like formatting the cells.

I made the code work and the sheet looks good, but I'm not sure if it's all versions proove.

For my code I have put a check in the references at 'Microsoft Excel 16.0 Object Library'
And this all works.
If I uncheck the reference, VBA returns errors.
No problem so far... just keep it on!?

Problem:
But what if an other user doesn't have it checked? Or has an older version of the Object Library?
It would give an error for him, wouldn't it?

I read things about early and late binding, where the early binding could give problems with this.
So I tried to change it to a late binding (using Objects).

When unchecking the Excel Object Library box, the code will still return errors.
Did I do something wrong? (Probably!)


Extra info:
sQuery = Name from the Query
sPath = Filepath where the sheet needs to be added
Both come from other sub

This is my code:

Private Sub cmdTransfer(ByVal sQuery As String, sPath As String)
                                                                                
On Error GoTo SubError

    Dim xlApp           As Object   
    Dim xlBook          As Object
    Dim xlSheet         As Object
    
    Dim rsl             As DAO.Recordset
    Dim iCols           As Integer
    Dim i               As Integer
    Dim bExcelOpened    As Boolean
    
    'Change cursor to hourglass
    DoCmd.Hourglass (True)
    
    '**********************************************************
    '                     GET DATA
    '**********************************************************

    'Put sQuery in recordset
    Set rsl = CurrentDb.OpenRecordset(sQuery, dbOpenSnapshot)

    'If empty > Exit Excel
    If rsl.RecordCount = 0 Then
        MsgBox "no data"
        GoTo SubExit
    End If
    
    '**********************************************************
    '                  SPREADSHEET BUILD UP
    '**********************************************************
    
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")    'Bind to existing instance of Excel
 
    If Err.Number <> 0 Then    'Could not get instance of Excel, so create a new one
        Err.Clear
        On Error GoTo SubError
        Set xlApp = CreateObject("Excel.Application")
        bExcelOpened = False
    Else    'Excel was already running
        bExcelOpened = True
    End If
    
    xlApp.Visible = False
    xlApp.screenupdating = False
    
    'Open Workbook on sPath
    Set xlBook = xlApp.Workbooks.Open(sPath)
    'Set sheet as first sheet
    Set xlSheet = xlBook.sheets.Add(Before:=xlBook.sheets(1))
    
    With xlSheet
        'General formatting sheet
        .Name = "List"
        .Tab.ColorIndex = 6
        .Cells.Font.Name = "Calibri"
        .Cells.Font.Size = 11
        
        'Add titles from table
        For iCols = 0 To rsl.Fields.Count - 1
            .Cells(3, iCols + 1).Value = rsl.Fields(iCols).Name
        Next
        
        'Format titles from tabel
        With xlSheet.Range(xlSheet.Cells(3, 1), _
            xlSheet.Cells(3, rsl.Fields.Count))
            .Font.Bold = True
            .Font.ColorIndex = 2
            .HorizontalAlignment = xlCenter
        End With
        
        'Add BIG title in A1
        With .Range("A1")
            .Value = "This sheet contains the list"
        End With
        
        'Format BIG title
        With xlSheet.Range(xlSheet.Cells(1, 1), _
            xlSheet.Cells(1, rsl.Fields.Count))
            .Merge
            .Cells.Font.Size = 15
            .Font.Bold = True
            .Font.ColorIndex = 1        'See: https://analysistabs.com/excel-vba/colorindex/
            .Interior.ColorIndex = 36
            .HorizontalAlignment = xlCenter
        End With
                
        'Get Data from sQuery
        .Range("A4").CopyFromRecordset rsl
  
        'Format first column
        With xlSheet.Columns("A:A")
            .VerticalAlignment = xlCenter
            .Font.Bold = True
        End With
        
        'Define range from Data sQuery
        Dim indexLastColumn As Integer
            indexLastColumn = .Cells(4, .Columns.Count).End(xlToLeft).Column
        Dim indexLastRow As Integer
            indexLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim RangeTabel As Range
            Set RangeTabel = xlSheet.Range(xlSheet.Cells(3, 1), xlSheet.Cells(indexLastRow, indexLastColumn))
                
        'Name Table
        Dim TableName As String
            TableName = "Tbl_List"
        
        'Format data sQuery as Table and name it
        xlSheet.ListObjects.Add(xlSrcRange, RangeTabel, , xlYes).Name = TableName

        'Format Table
        With xlSheet.ListObjects(TableName)
            .TableStyle = "TableStyleMedium2"
            .Range.AutoFilter
        End With

        'ReDefine LastRow
        indexLastRow = indexLastRow + 4
        
        'Add text in new last line + merg, colour and borders
        With xlSheet.Range(xlSheet.Cells(indexLastRow, 1), _
            xlSheet.Cells(indexLastRow, indexLastColumn))
            .Merge
            .Value = "For more information, contact me"
            .Interior.ColorIndex = 36
            .Borders(xlEdgeRight).LineStyle = XlLineStyle.xlContinuous
            .Borders(xlEdgeLeft).LineStyle = XlLineStyle.xlContinuous
            .Borders(xlEdgeTop).LineStyle = XlLineStyle.xlContinuous
            .Borders(xlEdgeBottom).LineStyle = XlLineStyle.xlContinuous
        End With
      
        'Autofit rows and columns
        .Columns("B").ColumnWidth = 120        'first wide to prevent early text wrap
        .Rows.AutoFit
        .Columns.AutoFit
        
        'Select first cel
        .Range("A1").Select
        'Select first sheet in workbook
        xlBook.sheets(1).Select
    End With
    
    xlApp.DisplayAlerts = False
        xlBook.Close True, sPath    'Save and close the workbook
    xlApp.DisplayAlerts = True
    
    'Close excel if is wasn't originally running
        If bExcelOpened = False Then
            xlApp.Quit
        End If
 
SubExit:
On Error Resume Next
    DoCmd.Hourglass False
    xlApp.Visible = True
    rsl.Close
    Set rsl = Nothing
    Set xlBook = Nothing
    Set xlSheet = Nothing
    xlApp.screenupdating = True
    Set xlApp = Nothing
    
    Exit Sub
    
SubError:
Error_Handler:
    MsgBox "An error occured:" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: cmdTransfer" & vbCrLf & _
           "Error Description: " & Err.Description _
           , vbOKOnly + vbCritical, "Error!"
     Resume SubExit
End Sub

Many thanks for helping me clearing this out!

Greetz
R

 

[Micron]

I guess the documentation is lacking then.

 

[RoryA]

Well, it doesn't say that you have to use CreateObject, that is just the example it gives. You can also use:

Set oExcel = New Excel.Application

with early binding. Personally I tend to use CreateObject regardless as it's easier to switch the code to late binding later if needed.

 

[roelandwatteeuw]

Sorry... I'm totally new to 'binding' and in my first post I tried to explain what I needed.
But it seemed like the only answer I got was 'you don't post it the right way'. (I'm very sorry)
And I didn't know how the explain in a way to get a clear answer.
So I wanted to close this topic because I didn't want to waste time from others with me being not clear.

RoryA made clear I need to declare al the Ecxcel-functions and this was a big help already and made most of the code running.

Dim XlLineStyle As Object
Const xlCenter As Long = -4108
Const xlUp As Long = -4126
Const xlToLeft As Long = -4159
Const xlSrcRange As Long = 1
Const xlYes As Long = 1
Const xlEdgeRight As Long = 10
Const xlEdgeLeft As Long = 7
Const xlEdgeBottom as Long = 9
Const xlEdgeTop as Long = 8
Const xlContinuous as Long = 1

And the second advice from RoryA, to change 'Range' to 'Object' seemed to solve another part of this puzzle

Dim RangeTable As Object

THANK RoryA!

The next problem I get is:
(In this step I want to paste the data from the table (without the titles) to cell A4)

'Get Data from sQuery

        .Range("A4").CopyFromRecordset rsl

Here I get the error (from my error handler):
Error Number: 1004
Error Description: Application-defined or object-defined error


When I watched my exported file, all the data I needed was in the sheet.
So I tried adding
- 'On Error Resume Next' before this part of the code
- 'On Error GoTo 0' after this part of the code

This gave me a new error on line:

Dim indexLastRow As Integer
            indexLastRow = xlsheet.Cells(.Rows.Count, 1).End(xlUp).Row

Error:
Here I get the error (from my error handler):
Error Number: 1004
Error Description: Application-defined or object-defined error

 

[RoryA]

I haven't used DAO in a while, but you may need to add rsl.movefirst before you try to copy the recordset. If that doesn't work, you may have data in the recordset that is producing errors, or very long text?

 

[welshgasman]

Qualify the object fully ?

indexLastRow = xlApp.xlsheet.Cells(.Rows.Count, 1).End(xlUp).Row

Plus if using Excel as an Object and NOT as the App, then you CANNOT use Excel constants, so lookup what xlUp is as a constant.

 

[roelandwatteeuw]

Hmm, today I don't get the DAO-error... strange

@welshgasman : looks like I made a typo for xlUp
I defined xlUp as: Const xlUp As Long = -4126
But it should be -4162




Next error (almost there)

Dim Foot as Object
Set Foot =  xlSheet.Range(xlSheet.Cells(indexLastRow, 1), _
            xlSheet.Cells(indexLastRow, indexLastColumn))
With Foot
            .Merge
            .Value = "For more information, contact me"
            .Interior.ColorIndex = 36
            .Borders(xlEdgeRight).LineStyle = XlLineStyle.xlContinuous    'HERE IS THE ERROR
            .Borders(xlEdgeLeft).LineStyle = XlLineStyle.xlContinuous       'AND HERE
            .Borders(xlEdgeTop).LineStyle = XlLineStyle.xlContinuous       'AND HERE AS WELL
            .Borders(xlEdgeBottom).LineStyle = XlLineStyle.xlContinuous 'AND HERE OFF COURSE TOO
End With

Error:
Run-time error '438': Object doesn't support this property or method

I tried:

.Borders(xlEdgeRight).LineStyle = xlApp.XlLineStyle.xlContinuous

and:

.Borders(xlEdgeRight).LineStyle = xlSheet.XlLineStyle.xlContinuous

and the combination:

.Borders(xlEdgeRight).LineStyle = xlApp.XlLineStyle.xlContinuous

but same error every time

This constants are defined:
Const xlEdgeRight As Long = 10
Const xlEdgeLeft As Long = 7
Const xlEdgeBottom as Long = 9
Const xlEdgeTop as Long = 8
Const xlContinuous as Long = 1

 

[RoryA]

Add:

Const xlContinuous As long = 1

then use:

            .Borders(xlEdgeRight).LineStyle = xlContinuous 
            .Borders(xlEdgeLeft).LineStyle = xlContinuous  
            .Borders(xlEdgeTop).LineStyle = xlContinuous   
            .Borders(xlEdgeBottom).LineStyle = xlContinuous

 

[roelandwatteeuw]

Sorry...
Error or my original code is:
Run-tim error '91': Object variable or With block variable not set

For the other 3 tries it was the error '438'

 

[roelandwatteeuw]

Add:

Const xlContinuous As long = 1

then use:

            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlEdgeLeft).LineStyle = xlContinuous 
            .Borders(xlEdgeTop).LineStyle = xlContinuous  
            .Borders(xlEdgeBottom).LineStyle = xlContinuous

Yes! This did the trick

Thanks!

I think the whole code is running now without the Excel Object Library on.

 

[roelandwatteeuw]

One last thing... hope you can make your magic work again

I want to run this Access with Cytrix (otherwise the process is slow)

Looks like this part gives a problem:

If Err.Number <> 0 Then    'Could not get instance of Excel, so create a new one
        Err.Clear
        On Error GoTo SubError
        Set xlApp = CreateObject("Excel.Application")
        bExcelOpened = False
    Else    'Excel was already running
        bExcelOpened = True
    End If

...
...

'Close excel if is wasn't originally running
        If bExcelOpened = False Then
            xlApp.Quit    'HERE
        End If

The xlApp.Quit takes a long time to execute and I get prompted whether to save the file, yes or no.

> When I run the code without Cytrix, I don't get the prompt
> Adding 'xlApp.DisplayAlerts = False' lets the file unsaved