Exporting Recordset to Spreadsheet

问题:

Just getting to grips some VBA (this stuff's new to me so bear with us!)

From query ContactDetails_SurveySoftOutcomes, I'm trying to first find a list of all the unique values in the DeptName field in that query, hence the rsGroup Dim storing a Grouped query on the DeptName field.

I'm then going to use this grouped list as way of cycling through the same query again, but passing through each unique entry as a filter on the whole recordset and export each filtered recordset to its own Excel spreadsheet... see the Do While Not loop.

My code's tripping up on the DoCmd.TransferSpreadsheet ... rsExport part. I'm a bit new to this, but I guess my Dim name rsExport for the recordset isn't accepted in this method..?

Is there an easy fix to the code I've already started or should I be using a completely different approach to achieve all this?

Code:

Public Sub ExportSoftOutcomes()

Dim rsGroup As DAO.Recordset
Dim Dept As String
Dim myPath As String

myPath = "C:\MyFolder\"

Set rsGroup = CurrentDb.OpenRecordset("SELECT ContactDetails_SurveySoftOutcomes.DeptName " _
& "FROM ContactDetails_SurveySoftOutcomes GROUP BY ContactDetails_SurveySoftOutcomes.DeptName", dbOpenDynaset)

Do While Not rsGroup.EOF

    Dept = rsGroup!DeptName

    Dim rsExport As DAO.Recordset
    Set rsExport = CurrentDb.OpenRecordset("SELECT * FROM ContactDetails_SurveySoftOutcomes " _
    & "WHERE (((ContactDetails_SurveySoftOutcomes.DeptName)='" & Dept & "'))", dbOpenDynaset)

    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, rsExport, myPath & Dept & "\" & Dept & " - Soft Outcomes Survey.xls", True

    rsGroup.MoveNext

Loop

End Sub

Fixed Code:

Public Sub ExportSoftOutcomes()

Dim rsGroup As DAO.Recordset
Dim Dept As String
Dim myPath As String

myPath = "C:\MyFolder\"

Set rsGroup = CurrentDb.OpenRecordset("SELECT ContactDetails_SurveySoftOutcomes.DeptName " _
& "FROM ContactDetails_SurveySoftOutcomes GROUP BY ContactDetails_SurveySoftOutcomes.DeptName", dbOpenDynaset)

Do While Not rsGroup.EOF
    Dept = rsGroup!DeptName

    Dim rsExportSQL As String
    rsExportSQL = "SELECT * FROM ContactDetails_SurveySoftOutcomes " _
    & "WHERE (((ContactDetails_SurveySoftOutcomes.DeptName)='" & Dept & "'))"

    Dim rsExport As DAO.QueryDef
    Set rsExport = CurrentDb.CreateQueryDef("myExportQueryDef", rsExportSQL)

    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "myExportQueryDef", myPath & Dept & "\" & Dept & " - Soft Outcomes Survey.xls", True

    CurrentDb.QueryDefs.Delete rsExport.Name

    rsGroup.MoveNext
Loop

End Sub

回答1:

You're right that your rsGroup parameter is wrong, Access expects a table name or select query.

Try this code:

strExport = "SELECT * FROM ContactDetails_SurveySoftOutcomes " _
& "WHERE (((ContactDetails_SurveySoftOutcomes.DeptName)='" & Dept & "'))"

Set qdfNew = CurrentDb.CreateQueryDef("myExportQueryDef", strExport)

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "myExportQueryDef", myPath & Dept & "\" & Dept & " - Soft Outcomes Survey.xls", True

CurrentDb.QueryDefs.Delete qdfNew.Name 'cleanup

Hope that works

回答2:

DoCmd.TransferSpreadsheet expects its third parameter to be a String (variable or literal) specifying the name of a table or query. So, instead of opening a DAO.Recordset you could create a DAO.QueryDef named something like "forExportToExcel" with the same SQL code, then use that name in the TransferSpreadsheet call.

回答3:

try this hope this will help you

Function Export2XLS(sQuery As String)
    Dim oExcel          As Object
    Dim oExcelWrkBk     As Object
    Dim oExcelWrSht     As Object
    Dim bExcelOpened    As Boolean
    Dim db              As DAO.Database
    Dim rs              As DAO.Recordset
    Dim iCols           As Integer
    Const xlCenter = -4108

    'Start Excel
    On Error Resume Next
    Set oExcel = GetObject(, "Excel.Application")    'Bind to existing instance of Excel

    If Err.Number <> 0 Then    'Could not get instance of Excel, so create a new one
        Err.Clear
        On Error GoTo Error_Handler
        Set oExcel = CreateObject("excel.application")
        bExcelOpened = False
    Else    'Excel was already running
        bExcelOpened = True
    End If
    On Error GoTo Error_Handler
    oExcel.ScreenUpdating = False
    oExcel.Visible = False   'Keep Excel hidden until we are done with our manipulation
    Set oExcelWrkBk = oExcel.Workbooks.Add()    'Start a new workbook
    Set oExcelWrSht = oExcelWrkBk.Sheets(1)

    'Open our SQL Statement, Table, Query
    Set db = CurrentDb
    Set rs = db.OpenRecordset(sQuery, dbOpenSnapshot)
    With rs
        If .RecordCount <> 0 Then
            'Build our Header
            For iCols = 0 To rs.Fields.Count - 1
                oExcelWrSht.Cells(1, iCols + 1).Value = rs.Fields(iCols).Name
            Next
            With oExcelWrSht.Range(oExcelWrSht.Cells(1, 1), _
                                   oExcelWrSht.Cells(1, rs.Fields.Count))
                .Font.Bold = True
                .Font.ColorIndex = 2
                .Interior.ColorIndex = 1
                .HorizontalAlignment = xlCenter
            End With
            oExcelWrSht.Range(oExcelWrSht.Cells(1, 1), _
                              oExcelWrSht.Cells(1, rs.Fields.Count)).Columns.AutoFit    'Resize our Columns based on the headings
            'Copy the data from our query into Excel
            oExcelWrSht.Range("A2").CopyFromRecordset rs
            oExcelWrSht.Range("A1").Select  'Return to the top of the page
        Else
            MsgBox "There are no records returned by the specified queries/SQL statement.", vbCritical + vbOKOnly, "No data to generate an Excel spreadsheet with"
            GoTo Error_Handler_Exit
        End If
    End With

    '    oExcelWrkBk.Close True, sFileName 'Save and close the generated workbook

    '    'Close excel if is wasn't originally running
    '    If bExcelOpened = False Then
    '        oExcel.Quit
    '    End If

Error_Handler_Exit:
    On Error Resume Next
    oExcel.Visible = True   'Make excel visible to the user
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    Set oExcelWrSht = Nothing
    Set oExcelWrkBk = Nothing
    oExcel.ScreenUpdating = True
    Set oExcel = Nothing
    Exit Function

Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: Export2XLS" & vbCrLf & _
           "Error Description: " & Err.Description _
           , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function