Question

我想在将数据放入工作表后创建一个表。以下代码从Access到Excel中删除查询结果。代码可以正常工作到＆＃34; xlSheet.Range（＆＃34; $ A $ 1：$ U $ 2＆＃34;）。选择＆＃34;但未能创建表。你能救我吗？

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

ListObjects创建 - 后期绑定 - 从Access到Excel

1 个答案: