ListObjectsの作成 - レイトバインディング - ExcelからAccessへ

Question

データをワークシートにドロップした後にテーブルを作成したいとします。 次のコードは、Accessからのクエリ結果をExcelにドロップします。コードは "xlSheet.Range（" $ A $ 1：$ U $ 2 "）までうまく動作します。"を選択したが、テーブルの作成に失敗しました。手伝って頂けますか？

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 

Answer 1

私はYowE3Kからの提案が解決しました。新しいコード

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