Transfer Multiple Tables from Microsoft Access onto a single Worksheet on an Excel Workbook

I've spent the last few hours scouring the net for a way to do this without finding a way.

Basically, I have 3 fairly small tables in access that I wish to transfer to an excel workbook on a single worksheet.

I am currently only able to insert these tables onto separate worksheets using the following coding:

DoCmd.TransferSpreadsheet transfertype:=acExport, _
spreadsheettype:=acSpreadsheetTypeExcel12, _
TableName:=DTable, FileName:=strWorksheetPathTable, _
hasfieldnames:=True, _
Range:="Data"

I wish to transfer 2 more tables onto the "Data" worksheet, 1 starting at D1 (table is a single column) and the other at G1.

If anyone could help me out with a push that'd be sweet.

Cheers, Dane I

Solution

add microsoft.activex data objects 2.8 to your references
add microsoft office object library to your references

Then create your spreadsheet like this:

dim xl as object: set xl = createobject("Excel.Application")
XL.Visible = False
XL.DisplayAlerts = False
dim wb as object: set wb = xl.Workbooks.Add
dim ws as object: set ws = wb.Worksheets(1)

dim rst as new adodb.recordset
dim r as long, c as long 'row and column
r = 1
c = 1

rst.open "SELECT * FROM Table1", currentproject.connection, adOpenKeyset, adLockReadOnly

if not rst.eof then
    ws.range(WS.Cells(r, c).Address).CopyFromRecordSet rst
end if

rst.close
rst.open "SELECT Count(*) FROM Table1", currentproject.connection etc

r = r + rst.fields(1) + 2

rst.Close

rst.open "SELECT * FROM Table2", etc

and so on.

wb.SaveAs FileName:=xlname
xl.Quit

set ws = nothing
set wb = nothing
set xl = nothing

This gives you what you want, with a line or two between each table. You can also now add code into the process to format your spreadsheet how you want if you wish to as well.

If a table needs column headings get them like this:

rst.open "SELECT * FROM Table1", currentproject.connection, adOpenKeyset, adLockReadOnly
dim ii as long
for ii = 0 to rst.fields.count - 1
    ws.cells(r, ii + 1) = rst.fields(ii)    'you can offset using c if you want
next
if not rst.eof then
    ws.range(WS.Cells(r, c).Address).CopyFromRecordSet rst
end if