Hello Boon
Here is a cut-down version of a function that I use a lot. It will create a
new, unsaved Excel workbook with one worksheet in it, and export a recordset
to that worksheet. You can pass it either a DAO.Recordset object, or the
name of a table or query, or a SQL SELECT string.
So, you could say:
Call ExportRecordsetToExcel( "Table A" )
or, to export the current recordset loaded into a form:
Call ExportRecordsetToExcel( Me.RecordsetClone )
Just paste the code into a standard module and it should work.
--
Good Luck
Graham Mandeno [Access MVP]
Auckland, New Zealand
========== start code ============
Public Function ExportRecordsetToExcel( _
Source As Variant _
) As Boolean
Const cProcName = "ExportRecordsetToExcel"
Const xlCenter = -4108 ' &hFFFFEFF4
Const xlHairline = 1
Dim oXL As Object
Dim oWkb As Object
Dim oRng As Object
Dim rs As DAO.Recordset
Dim i As Integer, iRows As Integer, iCols As Integer
Dim fRSOpened As Boolean, fHadErr As Boolean
'On Error GoTo ProcErr
Select Case VarType(Source)
Case vbString
Set rs = CurrentDb.OpenRecordset(Source)
fRSOpened = True
Case vbObject
If TypeOf Source Is DAO.Recordset Then
Set rs = Source
If Not rs.BOF Then rs.MoveFirst
End If
End Select
If rs Is Nothing Then
Err.Raise 5, cProcName, "Invalid source argument"
End If
With rs
If .RecordCount = 0 Then
Err.Raise 5, cProcName, "No records to export"
End If
.MoveLast
.MoveFirst
iRows = .RecordCount
iCols = .Fields.Count
End With
Set oXL = CreateObject("Excel.Application")
oXL.SheetsInNewWorkbook = 1
Set oWkb = oXL.Workbooks.Add
With oWkb.Worksheets(1)
Set oRng = .Range(.Cells(1, 1), .Cells(iRows + 1, iCols))
End With
With oRng
For i = 1 To iCols
oRng(1, i) = rs.Fields(i - 1).NAME
Next
With .Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
oRng(2, 1).CopyFromRecordset rs
For i = 7 To 12
.Borders(i).Weight = xlHairline
Next
For i = 1 To iCols
Select Case rs.Fields(i - 1).Type
Case dbCurrency
.Columns(i).Style = "Currency"
End Select
Next
.Columns.AutoFit
End With
ExportRecordsetToExcel = True
ProcEnd:
On Error Resume Next
If fRSOpened Then rs.Close
oXL.Visible = True
oXL.UserControl = True
Set oWkb = Nothing
Set oXL = Nothing
Exit Function
ProcErr:
MsgBox "Error #" & Err.Number & vbCrLf & Err.Description, _
vbExclamation, cProcName
fHadErr = True
Resume ProcEnd
End Function
=============== end code ======================
