Sub get_my_data()
'******************************************************************************
'short routine to use DAO sql statement to retrieve records from MS Access and export to MS Excel
'******************************************************************************
Dim path As String, db As Database, rs As Recordset
Dim sql As String, sql_select As String, sql_from As String
Dim oExcel As Object, oBook As Object, ws As Object
Dim output_row As Long
On Error GoTo error_handler 'trap any errors
path = "C:\Temp\mydb.mdb" 'declare your database
output_row = 2 'declare the starting row
'open a link to the Access database
Set db = Workspaces(0).OpenDatabase(path, dbDriverNoPrompt, ReadOnly:=True)
'******************************************************************************
'build up the SQL statement ready for use
'******************************************************************************
sql_select = "SELECT [MyTable].* "
sql_from = "FROM [MyTable];"
sql = sql_select & sql_from 'create the final sql statement ready for use
'******************************************************************************
'main routine to get the records
'******************************************************************************
Set rs = db.OpenRecordset(sql) 'run SQL statement to retrieve records
If (rs.RecordCount > 0) Then 'if records are found
'Start a new workbook in Excel
Set oExcel = CreateObject("Excel.Application")
oExcel.Visible = True
oExcel.Workbooks.Add 'add a new workbook
Set ws = oExcel.Worksheets.Add 'set up reference to a new sheet
'create field headings across the worksheet
For i = 0 To rs.Fields.Count - 1
ws.Cells(1, i + 1).Value = rs.Fields(i).Name
Next i
'format the headings to bold font
ws.Range(ws.Cells(1, 1), ws.Cells(1, rs.Fields.Count)).Font.Bold = True
With rs 'use recordset
Do While (Not .EOF) 'loop for complete recordset, ie all records
If (output_row >= 65000) Then 'prevent sheet overload
Set ws = oExcel.Worksheets.Add 'set up reference to a new sheet
output_row = 1 'reset output row back to the beginning
End If
For i = 0 To rs.Fields.Count - 1 'loop for all fields
ws.Cells(output_row, i + 1).Value = rs.Fields(i) 'send output to sheet
Next i
output_row = output_row + 1 'increment to next row
.MoveNext 'next record
Loop
End With
Else
MsgBox ("No Records Have Been Returned") 'give user message that no records have been retrieved
End If
'close recordset and database link to prevent 'bloating'
rs.Close
db.Close
Exit Sub
'exit routine if error occurs
error_handler:
MsgBox ("An Error Has Occurred (Error: " & Err.Number & " in get_my_data)")
End Sub