Exporting a recordset to Excel

[tim419762]

On occasion, I have the need to export a recordset to Excel. Sometimes I use it to check the recordset content without wading through the Locals Window; sometimes I use it as the end result of a process. Anyway, I'm posting the code I use to do it; I'm wondering if anyone has a more elegant way. My technique uses automation to fill in the content of each cell, which takes a while on a large dataset. I'm interested to get feedback on other ways to get the job done.

Incidentally, I'm aware of the transferspreadsheet command for tables and queries; I use the method below when I'm dynamically creating the SQL for a recordset or defining the fields myself and then populating them.

Input is welcome.

Public Sub ExportRecordsetToExcel(rstIn As ADODB.Recordset)
On Error GoTo error_handler
    Dim objXLApp As Excel.Application
    Dim objXLBook As Excel.Workbook
    Dim i As Integer
    Dim j As Integer
    
    Set objXLBook = Excel.Workbooks.Add
    Set objXLApp = objXLBook.Parent
    
    objXLApp.Visible = True
    objXLBook.Windows(1).Visible = True
        
    objXLApp.Application.ScreenUpdating = True
    objXLApp.WindowState = xlMaximized
        
    With objXLApp
        j = 1
        For i = 1 To rstIn.Fields.Count
            .Worksheets("Sheet1").Cells(j, i).Select
            .ActiveCell.FormulaR1C1 = rstIn.Fields(i - 1).Name
        Next i
        j = 2
        Do Until rstIn.EOF
            For i = 1 To rstIn.Fields.Count
                .Worksheets("Sheet1").Cells(j, i).Select
                If rstIn.Fields(i - 1).Type = adVarChar Then
                    .ActiveCell.FormulaR1C1 = "'" & Right(rstIn.Fields(i - 1), 32766)
                Else
                    .ActiveCell.FormulaR1C1 = Right(rstIn.Fields(i - 1), 32767)
                End If
            Next i
            rstIn.MoveNext
            j = j + 1
        Loop
    End With
    If rstIn.RecordCount > 0 Then
        rstIn.MoveFirst
    End If
        
    Set objXLBook = Nothing
    Set objXLApp = Nothing
new_exiter:
    On Error Resume Next
    Exit Sub
error_handler:
    MsgBox "An error occurred.  Info:" & Err.Number & " - " & Err.Description
    Resume new_exiter
End Sub

 

[pbaldy]

Play around with the CopyFromRecordset method and see if it works faster for you (it's an Excel method)

 

[DCrake]

here is a useful link to MSKB article

Click here