Sub TestExcel()
Dim strTableNameArray(1 To 16) As String
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim rst As ADODB.Recordset
Dim lngRow As Long
Dim f As ADODB.Field
Dim intFieldNumber As Integer
Dim I As Long
strTableNameArray(1) = "TableName1"
strTableNameArray(2) = "TableName2"
strTableNameArray(3) = "TableName3"
strTableNameArray(4) = "TableName4"
strTableNameArray(5) = "TableName5"
strTableNameArray(6) = "TableName6"
strTableNameArray(7) = "TableName7"
strTableNameArray(8) = "TableName8"
strTableNameArray(9) = "TableName9"
strTableNameArray(10) = "TableName10"
strTableNameArray(11) = "TableName11"
strTableNameArray(12) = "TableName12"
strTableNameArray(13) = "TableName13"
strTableNameArray(14) = "TableName14"
strTableNameArray(15) = "TableName15"
strTableNameArray(16) = "TableName16"
Set xlApp = New Excel.Application
' Use this to show the excel application
xlApp.Visible = True
' Create a new workbook and set xlSheet as the first worksheet
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Sheets(1)
' Create new recordset object
Set rst = New ADODB.Recordset
' Copy headers to first row of excel sheet using the field names from first table
strSQL = "SELECT * FROM " & strTableNameArray(1)
rst.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly
If Not rst.EOF Then
For intFieldNumber = 0 To rst.Fields.Count - 1
xlSheet.cells(1, intFieldNumber + 1).Value = rst.Fields(intFieldNumber).Name
Next
End If
rst.Close
' Set starting row for values
lngRow = 2
' Loop through tables and copy contents to Excel sheet
For I = 1 To 16
' Open the table as an ADODB recordset
rst.Open strTableNameArray(I), CurrentProject.Connection, adOpenStatic, adLockReadOnly
' Append the values for each record into the worksheet table
Do While Not rst.EOF
' loop through fields and copy values
For intFieldNumber = 0 To rst.Fields.Count - 1
xlSheet.cells(lngRow, intFieldNumber + 1).Value = rst.Fields(intFieldNumber).Value
Next
' Increase worksheet row counter
lngRow = lngRow + 1
' Go to next record
rst.MoveNext
Loop
' Close recordset
rst.Close
Next
Set rst = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
End Sub