7

刚刚开始掌握一些 VBA（这东西对我来说是新的，所以请耐心等待！）

从查询ContactDetails_SurveySoftOutcomes中，我试图首先在该查询的DeptName字段中找到所有唯一值的列表，因此Dim 在DeptNamersGroup字段上存储分组查询。

然后，我将使用此分组列表作为再次循环执行相同查询的方式，但将每个唯一条目作为整个记录集的过滤器传递，并将每个过滤后的记录集导出到其自己的 Excel 电子表格...查看Do While Not循环。

我的代码在DoCmd.TransferSpreadsheet...rsExport部分出错了。我对此有点陌生，但我猜我rsExport的记录集的 Dim 名称在这种方法中不被接受..？

我已经开始的代码是否有一个简单的修复方法，或者我应该使用完全不同的方法来实现这一切？

代码：

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

固定代码：

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
4

3 回答 3

14

你是对的，你的rsGroup参数是错误的，Access 需要一个表名或选择查询。

试试这个代码：

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

希望有效

于 2013-05-02T12:31:49.143 回答
6

试试这个希望这会帮助你

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
于 2015-04-06T11:03:07.507 回答
3

DoCmd.TransferSpreadsheet期望它的第三个参数是一个字符串（变量或文字），指定表或查询的名称。因此，DAO.Recordset您可以使用相同的 SQL 代码创建一个DAO.QueryDef名为“forExportToExcel”的名称，而不是打开一个名称，然后在 TransferSpreadsheet 调用中使用该名称。

于 2013-05-02T12:32:10.857 回答