ListObjects創建 - 後期綁定 - 從Access到Excel

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