Sub ExportDataToExcel(dataSource As String)
'Requires Reference to Microsoft Excel Object Library
On Error GoTo errExportDataToExcel
Dim rs As Recordset
Dim Xrow, Xcol, rowCtr As Integer
Dim ObjXL As Object
Dim objWkb As Excel.Workbook
Dim objSht As Excel.Worksheet
Set rs = CurrentDb.OpenRecordset("select * from " & dataSource)
If rs.RecordCount > 0 Then
'check & close any instance of Excel running
Set ObjXL = GetObject(, "Excel.Application")
If Not (ObjXL Is Nothing) Then
ObjXL.Application.DisplayAlerts = False
ObjXL.Workbooks.Close
ObjXL.Quit
Set ObjXL = Nothing
End If
Set ObjXL = CreateObject("Excel.Application")
ObjXL.Visible = False
Set objWkb = ObjXL.Workbooks.Add
Set objSht = objWkb.Worksheets(1)
'objSht.Activate
'Put the title first in row 1, column 1
With objSht.Cells(1, 1)
.Value = "BMD Architects: Workloads"
.HorizontalAlignment = xlLeft
With .Font
.Name = "Tahoma"
.FontStyle = "Normal"
.Size = 16
End With
With .Range("A1:F1")
.Merge
.Interior.Color = RGB(175, 238, 238) 'Pale Blue
End With
End With
'Set start of cell to begin data plotting
Xrow = 3
Xcol = 1
rowCtr = 1 'always 1
'plotting of data starts here
Do While Not rs.EOF
'put column name once
If rowCtr = 1 Then
For iField = 0 To rs.Fields.Count - 1
'format the cell first
With objSht.Cells(Xrow, Xcol + iField)
.HorizontalAlignment = xlLeft
.Interior.Color = RGB(255, 255, 0)
With .Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 11
End With
End With
'then put the column label
objSht.Cells(Xrow, Xcol + iField).Value = rs.Fields(iField).Name
Next
rowCtr = 0
Xrow = Xrow + 1
End If
'actual data plotting
For iField = 0 To rs.Fields.Count - 1
objSht.Cells(Xrow, Xcol + iField).Value = rs.Fields(iField).Value
Next
Xrow = Xrow + 1
rs.MoveNext
Loop
End If
'save the workbook
objWkb.SaveAs CurrentProject.Path & "\" & dataSource
objWkb.Close
'close the workbook
Set objSht = Nothing
Set objWkb = Nothing
ObjXL.Quit
'notify if done processing
MsgBox "Done generating " & dataSource & " to " & CurrentProject.Path
Exit Sub
errExportDataToExcel:
'bypass if error 432 & 429
If Err = 432 Or Err = 429 Then
Resume Next
'otherwise display other error
Else
MsgBox Err & ": " & Err.Description
End If
End Sub
'Column labels & formatting
Xrow = 3
Xcol = 1
For ifield = 0 To rs.Fields.Count - 1
With objSht.Cells(Xrow, Xcol + ifield)
.HorizontalAlignment = xlLeft
.Interior.Color = RGB(255, 255, 0)
With .Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 11
End With
End With
objSht.Cells(Xrow, Xcol + ifield).Value = rs.Fields(ifield).Name
Next ifield
'Data population from recordset
objSht.Range("A4").CopyFromRecordset rs
Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.
Comments (3)
Author
Commented:Commented:
The function (xlLastRow) at the link below is also very helpful for Excel automation.
http://www.vbaexpress.com/kb/getarticle.php?kb_id=417
Commented: