ListObjects创build – 后期绑定 – 从Access到Excel
我想在将数据放入工作表后创build一个表。 以下代码将查询结果从Access下载到Excel。 代码工作正常“xlSheet.Range（”$ A $ 1：$ U $ 2“）。select”但未能创build表。 你可以帮我吗？
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 YowE3K的build议确实解决了我的问题。 谢谢你的帮助
这里是新的代码
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