[AccessD] Copy recordset to excel spreadsheet

Hi Chester,

I do a lot of exporting to Excel and have for quite a while.  I am not sure
why, but maybe because of errors like you are seeing, I prefer to loop
through the recordset and export as I go.  Below is the basic code I use.
Make sure Tools > References include the Excel library

Jennifer Gross
805-480-1921

Public Sub ToExcel()
On Error GoTo ErrorHandler
    
    Dim strErrMsg As String  'for Error Handling
    Dim X As Integer
    Dim objXL As Excel.Application
    Dim objWkb As Excel.Workbook
    Dim objSht As Excel.Worksheet
    Dim db As DAO.Database
    Dim qdf As DAO.QueryDef
    Dim prm As DAO.Parameter
    Dim rsACData As DAO.Recordset

    Set db = CurrentDb
    Set qdf = db.QueryDefs("somequery")
    For Each prm In qdf.Parameters
        prm.Value = Eval(prm.Name)
    Next prm
    Set rsACData = qdf.OpenRecordset(dbOpenDynaset)
    
    'export data to Excel
    If (Not rsACData.EOF) And (Not rsACData.BOF) Then
        If fIsAppRunning("Excel") Then
            Set objXL = GetObject(, "Excel.Application")
        Else
            Set objXL = CreateObject("Excel.Application")
        End If
        With objXL
            .Visible = False
            Set objWkb = .Workbooks.Add
            Set objSht = objWkb.Worksheets(1)
            With objSht
                .Cells(1, 1) = "Title"
                .Cells(2, 1) = "Another Title”
                .Cells(1, 1).Font.Bold = True
                .Cells(2, 1).Font.Bold = True
                
                .Cells(3, 1) = "Column Heading"
                .Cells(3, 2) = "Column Heading"
                .Cells(3, 3) = "Column Heading"
                .Cells(3, 4) = "Column Heading"
                .Cells(3, 5) = "Column Heading"
                .Cells(3, 6) = "Column Heading"
                .Cells(3, 7) = "Column Heading"
                
                .Rows(3).Font.Bold = True
                .Rows(3).WrapText = True
                
                .Columns(1).ColumnWidth = 10
                .Columns(2).ColumnWidth = 15
                .Columns(3).ColumnWidth = 10
                .Columns(4).ColumnWidth = 30
                .Columns(5).ColumnWidth = 10
                .Columns(6).ColumnWidth = 10
                .Columns(7).ColumnWidth = 10
                                
                X = 4
                rsACData.MoveFirst
                Do Until rsACData.EOF
                    .Cells(X, 1) = rsACData!SomeField
                    .Cells(X, 2) = rsACData! SomeField
                    .Cells(X, 3) = rsACData! SomeField
                    .Cells(X, 4) = Format(rsACData! SomeDateField, "Short
Date")
                    .Cells(X, 5) = rsACData! SomeField
                    .Cells(X, 6) = rsACData! SomeField
                    .Cells(X, 7) = rsACData! "=B" & X & "+C" & X & "+E" & X
& "+F" & X
                    X = X + 1
                    rsACData.MoveNext
                Loop

	      'totals
                    .Cells(X, 1) = "Totals"
                    .Cells(X, 2) = "=Sum(B4:B" & X - 1 & ")"
                    .Cells(X, 3) = "=Sum(C4:C" & X - 1 & ")"
                    .Cells(X, 5) = "=Sum(E4:E" & X - 1 & ")"
                    .Cells(X, 6) = "=Sum(F4:F" & X - 1 & ")"
                
                .Columns(5).NumberFormat = "#,##0.0_)"
	    .Columns(6).NumberFormat = "$#,##0.00_);[Red] ($#,##0.00)"
                
                .PageSetup.PrintGridlines = True
                .PageSetup.Orientation = xlPortrait
                .PageSetup.PrintTitleRows = .Rows(2).Address
                objXL.Visible = True
                objXL.Cells(4, 1).Select
                objXL.ActiveWindow.FreezePanes = True
                            
            End With
        End With
    Else
        MsgBox "No data", vbOKOnly + vbExclamation, "No data"
    End If
    

ExitHere:
    qdf.Close
    rsACData.Close
    Set db = Nothing
    Set objSht = Nothing
    Set objWkb = Nothing
    Set objXL = Nothing
    DoCmd.Hourglass False
    DoCmd.SetWarnings True
    Exit Sub
    
ErrorHandler:
    Select Case Err
        Case 91
            'do nothing - object never opened
            Err.Clear
            Resume Next
        Case Else
            strErrMsg = "An error occurred in " & "ToExcel" & vbCrLf &
vbCrLf & vbCrLf
            strErrMsg = strErrMsg & "Error #: " & Format$(Err.Number) &
vbCrLf & vbCrLf
            strErrMsg = strErrMsg & "Error Description: " & Err.Description
            MsgBox strErrMsg, vbInformation, "ToExcel"
            Resume ExitHere
    End Select
End Sub



-----Original Message-----
From: accessd-bounces at databaseadvisors.com
[mailto:accessd-bounces at databaseadvisors.com] On Behalf Of Kaup, Chester
Sent: Tuesday, April 26, 2011 6:50 AM
To: Access Developers discussion and problem solving
Subject: [AccessD] Copy recordset to excel spreadsheet

I am using the following code to copy a recordset to an excel spreadsheet.
Just to be safe I check for missing references and found none.It generates
an error
Run time error 430
Class does not support Automation or does not support expected interface.
What might I be doing wrong?

Function CopytoSpreadsheet()

Dim objXL As Object
Dim xlWB As Object
Dim xlWS As Object
Dim rst As DAO.Recordset
Dim fld As Field

Dim strExcelFile As String


Set objXL = CreateObject("Excel.Application")
objXL.Visible = True
Set xlWB = objXL.Workbooks.Add
Set xlWS = xlWB.Worksheets(1)
xlWS.Name = "Worksheet1"

Set rst = CurrentDb.OpenRecordset("tbl DirectoryName")

rst.MoveFirst
xlWS.Range("A2").CopyFromRecordset rst

xlWB.SaveAs "C:\files\Excel\SSTest.xls"
rst.Close

Set rst = Nothing

End Function

Chester Kaup
Engineering Technician
Kinder Morgan CO2 Company, LLP
Office (432) 688-3797
FAX (432) 688-3799

 


-- 
AccessD mailing list
AccessD at databaseadvisors.com
http://databaseadvisors.com/mailman/listinfo/accessd
Website: http://www.databaseadvisors.com