Reputation: 989
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
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