Code Snippets → Export A Form’s Recordset To Excel

Copy this code into a standard (not form or report) module. Name the module something other than this function name and make sure to set a reference to DAO if you don’t have one set already.

You can then call it like this for a form (if the code is on the form you want then):

Call Send2Excel(Me, "SheetNameHereInQuotes")

To use it with a form which the code is not on use (the form must be open):

Call Send2Excel(Forms!YourFormNameHere, "SheetNameInQuotes")

To use it with a subform and the code not be on the subform:

'if code is on the main form:
Call Send2Excel(Me.SubformControl.Form, "SheetNameInQuotes")


'if code is on a completely different form:
Call Send2Excel(Forms!YourMainFormName.SubformControl.Form, "SheetNameInQuotes")

Just a note – SubformControl means the control on the main form which houses the subform and not the subform name itself (unless they share the same name).

Public Function Send2Excel(frm As Form, Optional strSheetName As String)
' frm is the name of the form you want to send to Excel
' strSheetName is the name of the sheet you want to name it to
    Dim rst As DAO.Recordset
    Dim ApXL As Object
    Dim xlWBk As Object
    Dim xlWSh As Object
    Dim fld As DAO.Field
    Const xlCenter As Long = -4108
    Const xlBottom As Long = -4107
    On Error GoTo err_handler
    Set rst = frm.RecordsetClone
    Set ApXL = CreateObject("Excel.Application")
    Set xlWBk = ApXL.Workbooks.Add
    ApXL.Visible = True
    Set xlWSh = xlWBk.Worksheets("Sheet1")
    If Len(strSheetName) > 0 Then
        xlWSh.Name = Left(strSheetName, 34)
    End If

    For Each fld In rst.Fields
        ApXL.ActiveCell = fld.Name
        ApXL.ActiveCell.Offset(0, 1).Select
    xlWSh.Range("A2").CopyFromRecordset rst
    ' This is included to show some of what you can do about formatting.  
    'You can comment out or delete
    ' any of this below that you don't want to 
    'use in your own export.
    With ApXL.Selection.Font
        .Name = "Arial"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
    End With
    ApXL.Selection.Font.Bold = True
    With ApXL.Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .MergeCells = False
    End With
    ' selects all of the cells
    ' does the "autofit" for all columns
    ' selects the first cell to unselect all cells
    Set rst = Nothing
    Exit Function
    DoCmd.SetWarnings True
    MsgBox Err.Description, vbExclamation, Err.Number
    Exit Function
End Function