Jean-Marc Flamand
Jean-Marc Flamand

Reputation: 989

ListObjects creation - late binding - From Access to Excel

I want to create a table after dropping the data in to a worksheet. The following code drop a query result from Access to Excel. The code works fine up to "xlSheet.Range("$A$1:$U$2").Select" but failed to create the table. Can you help me?

Option Compare Database
'Use Late Bingding befor move on prod remove Excel ref
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Dim xlTable As Object
'End of late Binding

Sub testExport()
    Dim QryName As String

    QryName = "BOM_REPORT_UNION"
    ExportToExcelUsingQryName (QryName)    
End Sub

Sub ExportToExcelUsingQryName(QueryName As String)
    On Error GoTo SubError

    'Late Binding
    Set xlApp = CreateObject("Excel.Application")
    'Late Binding end

    Dim SQL As String
    Dim i As Integer

    'Show user work is being performed
    DoCmd.Hourglass (True)

    'Get the SQL for the queryname and Execute query and populate recordset
    SQL = CurrentDb.QueryDefs(QueryName).SQL
    Set rsBOMTopDown = CurrentDb.OpenRecordset(SQL, dbOpenSnapshot)

    'If no data, don't bother opening Excel, just quit
    If rsBOMTopDown.RecordCount = 0 Then
        MsgBox "No data selected for export", vbInformation + vbOKOnly, "No data exported"
        GoTo SubExit
    End If

    '*********************************************
    '             BUILD SPREADSHEET
    '*********************************************
    'Create an instance of Excel and start building a spreadsheet

    xlApp.Visible = False
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Worksheets(1)

    'Set column heading from recordset
    SetColumnHeadingFromRecordset
    'Copy data from recordset to Worksheet
    xlSheet.Range("A2").CopyFromRecordset rsBOMTopDown

    'Create Table
    xlSheet.Range("$A$1:$U$2").Select

    'Set xlTable = ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes).Name = "tblBOMTopDown" ' error 424 - Object Required
    'Set xlTable = xlBook.xlSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes).Name = "tblBOMTopDown"  ' error 424 - Object Required
    Set xlTable = xlSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes)   ' error 5 invalid procedure call or argument
    'Set xlTable = xlSheet.ListObjects.Add(xlSrcRange,  Selection, , xlYes).Name = "tblBOMTopDown"


SubExit:
    On Error Resume Next

    DoCmd.Hourglass False
    xlApp.Visible = True
    rsBOMTopDown.Close
    Set rsBOMTopDown = Nothing

    Exit Sub

SubError:
    MsgBox "Error Number: " & Err.Number & "= " & Err.description, vbCritical + vbOKOnly, _
           "An error occurred"

    GoTo SubExit

End Sub

Sub SetColumnHeadingFromRecordset()              '(ByVal xlSheet As Object, rsBOMTopDown As Recordset)
    For cols = 0 To rsBOMTopDown.Fields.count - 1
        xlSheet.Cells(1, cols + 1).Value = rsBOMTopDown.Fields(cols).Name
    Next
End Sub

Upvotes: 0

Views: 954

Answers (1)

Jean-Marc Flamand
Jean-Marc Flamand

Reputation: 989

The proposal from YowE3K did solve my issued. Thank for the help

Here the new code

Option Compare Database
'Use Late Bingding befor move on prod remove Excel ref
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Dim xlTable As Object
'End of late Binding

'XlListObjectSourceType Enumeration (Excel) for late Binding
'Info: https://msdn.microsoft.com/en-us/library/office/ff820815.aspx
'-------------------------------------------------------------------

Public Const gclxlSrcRange As Long = 1          'Range

Sub testExport()
    Dim QryName As String

    QryName = "BOM_REPORT_UNION"
    ExportToExcelUsingQryName (QryName)    
End Sub

Sub ExportToExcelUsingQryName(QueryName As String)
    On Error GoTo SubError

    'Late Binding
    Set xlApp = CreateObject("Excel.Application")
    'Late Binding end

    Dim SQL As String
    Dim i As Integer

    'Show user work is being performed
    DoCmd.Hourglass (True)

    'Get the SQL for the queryname and Execute query and populate recordset
    SQL = CurrentDb.QueryDefs(QueryName).SQL
    Set rsBOMTopDown = CurrentDb.OpenRecordset(SQL, dbOpenSnapshot)

    'If no data, don't bother opening Excel, just quit
    If rsBOMTopDown.RecordCount = 0 Then
        MsgBox "No data selected for export", vbInformation + vbOKOnly, "No data exported"
        GoTo SubExit
    End If

    '*********************************************
    '             BUILD SPREADSHEET
    '*********************************************
    'Create an instance of Excel and start building a spreadsheet

    xlApp.Visible = False
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Worksheets(1)

    'Set column heading from recordset
    SetColumnHeadingFromRecordset
    'Copy data from recordset to Worksheet
    xlSheet.Range("A2").CopyFromRecordset rsBOMTopDown

    'Create Table
    xlSheet.Range("$A$1:$U$2").Select

        Set xlTable = xlSheet.ListObjects.Add(gclxlSrcRange, xlApp.Selection, , xlYes)
    xlTable.Name = "tblBOMTopDown"



SubExit:
    On Error Resume Next

    DoCmd.Hourglass False
    xlApp.Visible = True
    rsBOMTopDown.Close
    Set rsBOMTopDown = Nothing

    Exit Sub

SubError:
    MsgBox "Error Number: " & Err.Number & "= " & Err.description, vbCritical + vbOKOnly, _
           "An error occurred"

    GoTo SubExit

End Sub

Sub SetColumnHeadingFromRecordset()              '(ByVal xlSheet As Object, rsBOMTopDown As Recordset)
    For cols = 0 To rsBOMTopDown.Fields.count - 1
        xlSheet.Cells(1, cols + 1).Value = rsBOMTopDown.Fields(cols).Name
    Next
End Sub

Upvotes: 2

Related Questions