VBA Access. Función para exportar un recordset a Excel.

Public Sub Export2Excel(ByRef rs As Variant, Optional ByVal bShowColumnNames As Boolean = True)
On Error GoTo error
    Dim xlApp As Object
    Dim xlWb As Object
    Dim xlWs As Object

    Dim recArray As Variant

    Dim strDB As String
    Dim fldCount As Integer
    Dim recCount As Long
    Dim iCol As Integer
    Dim iRow As Integer

    ' Create an instance of Excel and add a workbook
    Set xlApp = CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Add
    Set xlWs = xlWb.Worksheets("Hoja1")

    ' Copy field names to the first row of the worksheet
    If bShowColumnNames Then
        fldCount = rs.Fields.Count
        For iCol = 1 To fldCount
            xlWs.Cells(1, iCol).value = rs.Fields(iCol - 1).Name
        Next
    End If
   
    ' Check version of Excel
    If Val(Mid(xlApp.Version, 1, InStr(1, xlApp.Version, ".") - 1)) > 8 Then
        'EXCEL 2000,2002,2003, or 2007: Use CopyFromRecordset
     
        ' Copy the recordset to the worksheet, starting in cell A2
        xlWs.Cells(IIf(bShowColumnNames, 2, 1), 1).CopyFromRecordset rs
        'Note: CopyFromRecordset will fail if the recordset
        'contains an OLE object field or array data such
        'as hierarchical recordsets
    Else
        MsgBox "Versión instalada de excel no soportada!", vbCritical
        Exit Sub
    End If

    ' Auto-fit the column widths and row heights
    xlApp.Selection.CurrentRegion.Columns.AutoFit
    xlApp.Selection.CurrentRegion.Rows.AutoFit

    ' Display Excel and give user control of Excel's lifetime
    xlApp.Visible = True
    xlApp.UserControl = True

    ' Release Excel references
    Set xlWs = Nothing
    Set xlWb = Nothing
    Set xlApp = Nothing
       
Exit Sub
Resume
error:
    MsgBox Err.Description
End Sub