ExcellToRSet

Sub ToExcel(Sn As Recordset, strCaption As String)
        Dim oExcel As Object
        Dim objExlSht As Object' OLE automation object
        Dim stCell As ExlCell
        DoEvents
        On Error Resume Next
        Set oExcel = GetObject(, "Excel.Application")
        'If Excel is not launched start it
        If Err = 429 Then
            Err = 0
            Set oExcel = CreateObject("Excel.Application")
            'Can't create object
            If Err = 429 Then
                MsgBox Err & ": " & Error, vbExclamation + vbOKOnly
                Exit Sub
            End If
        End If
        oExcel.Workbooks.Add
        oExcel.Worksheets("sheet1").Name = strCaption
        Set objExlSht = oExcel.ActiveWorkbook.Sheets(1)
        stCell.row = 1
        stCell.col = 1
        'Place the fields across the top of the spreadsheet:
        CopyRecords Sn, objExlSht, stCell
        'Give the user control
        oExcel.Visible = True
        oExcel.Interactive = True
        'Clean up:
        Set objExlSht = Nothing ' Remove object variable.
        Set oExcel = Nothing' Remove object variable.
        Set Sn = Nothing ' Remove snapshot object.
    End Sub

'User defined type to help determine the

'starting cell in the range receiving the recordset

Private Type ExlCell
row As Long
col As Long
End Type
'___________________________________________________________

Private Sub CopyRecords(rs As Recordset, ws As Worksheet, _
StartingCell As ExlCell)
Dim SomeArray() As Variant
Dim row As Long, col As Long
Dim fd As Field
'You might want to check if rs is not empty

rs.MoveLast
ReDim SomeArray(rs.RecordCount + 1, rs.Fields.Count)
'Copy column headers to array

col = 0
For Each fd In rs.Fields
SomeArray(0, col) = fd.Name
col = col + 1
Next
'Copy rs to some array

rs.MoveFirst
For row = 1 To rs.RecordCount - 1
For col = 0 To rs.Fields.Count - 1
SomeArray(row, col) = rs.Fields(col).Value
' Excel will be offended if you try setting one

' of its cells to a NULL

If IsNull(SomeArray(row, col)) Then _
SomeArray(row, col) = ""
Next
rs.MoveNext
Next
'The range should have the same number of

'rows and cols as in the recordset

ws.Range(ws.Cells(StartingCell.row, StartingCell.col), _
ws.Cells(StartingCell.row + rs.RecordCount + 1, _
StartingCell.col + rs.Fields.Count)).Value = SomeArray
End Sub

Sub ToExcel(Sn As Recordset, strCaption As String)
Dim oExcel As Object
Dim objExlSht As Object' OLE automation object
Dim stCell As ExlCell
DoEvents
On Error Resume Next
Set oExcel = GetObject(, "Excel.Application")
'If Excel is not launched start it

If Err = 429 Then
Err = 0
Set oExcel = CreateObject("Excel.Application")
'Can't create object

If Err = 429 Then
MsgBox Err & ": " & Error, vbExclamation + vbOKOnly
Exit Sub
End If
End If
oExcel.Workbooks.Add
oExcel.Worksheets("sheet1").Name = strCaption
Set objExlSht = oExcel.ActiveWorkbook.Sheets(1)
stCell.row = 1
stCell.col = 1
'Place the fields across the top of the spreadsheet:

CopyRecords Sn, objExlSht, stCell
'Give the user control

oExcel.Visible = True
oExcel.Interactive = True
'Clean up:

Set objExlSht = Nothing ' Remove object variable.
Set oExcel = Nothing' Remove object variable.
Set Sn = Nothing ' Remove snapshot object.
End Sub