VBA运行时错误3021-无当前记录

Eliseo Di Folco 发表于 Dev

艾丽莎·迪·佛尔科（Elisha Di Folco）

我正在尝试将多个数据集导出到各自的新Excel文件。

   Public Sub MultipleQueries()

Dim i As Integer
Dim Mailer As Database
Dim rs1 As Recordset
Dim rs2 As Recordset
Dim qdf As QueryDef

Set Mailer = CurrentDb
Set rs1 = Mailer.OpenRecordset("MailerData")
Set qdf = Mailer.CreateQueryDef("CCspl", "PARAMETERS CostCentre Text ( 255 );SELECT MonthlyFteData.CostCentre, MonthlyFteData.EmpName, MonthlyFteData.Workload FROM MonthlyFteData WHERE (((MonthlyFteData.CostCentre)=[CostCentre]))")

For i = 0 To rs1.RecordCount - 1

qdf.Parameters("CostCentre") = rs1.Fields("CostCentre")

    Dim oExcel As Object
   Dim oBook As Object
   Dim oSheet As Object
   Set oExcel = CreateObject("Excel.Application")
   Set oBook = oExcel.Workbooks.Add
   Set oSheet = oBook.Worksheets(1)

Set rs2 = qdf.OpenRecordset()

With rs2

oSheet.Range("A2").CopyFromRecordset rs2
oBook.SaveAs "C:\Users\807140\Downloads\" & rs2.Fields("CostCentre") & ".xlsx"

rs2.Close
oExcel.Quit
Set oExcel = Nothing

End With

rs1.MoveNext
Next i

qdf.Close
Set qdf = Nothing
rs1.Close

End Sub

但是我收到运行时错误3021-没有当前记录

我用

oSheet.Range("A2").CopyFromRecordset rs2
oBook.SaveAs "C:\Users\807140\Downloads\" & rs2.Fields("CostCentre") & ".xlsx"

和

Debug.Print .RecordCount

而且我确实得到了rs2的适当记录数。

如何修复我的代码以消除错误？

dbmitch

这段代码有@Andre和Ryan指出的一些问题。

您没有在重用Excel对象，而是在重新定义仅应定义一次的对象，使用永远不会被引用的With，因此它只会增加代码，而无济于事。

您还将在代码中动态创建参数查询-而不是在SQL中创建参数查询并将其保存以按名称重用。

您可以尝试这段重写的代码，看看它是否更适合您。我确实相信预定义查询是更好的方法-然后我将在循环内关闭查询，并在每次启动时将其重置。我刚刚看到，当在循环内部重用querydef而不重置它们时，会发生奇怪的事情。

无论如何尝试一下-并在导致错误的特定行上报告

Public Sub MultipleQueries()

    Dim i       As Integer
    Dim Mailer  As Database
    Dim rs1     As Recordset
    Dim rs2     As Recordset
    Dim qdf     As QueryDef

    Dim oExcel  As Object
    Dim oBook   As Object
    Dim oSheet  As Object

    ' Only Open and Close Excel once
    Set oExcel = CreateObject("Excel.Application")

    Set Mailer = CurrentDb
    Set rs1 = Mailer.OpenRecordset("MailerData")

    ' Ideally you'd put this create query ahead of time instead of dynamically
    Set qdf = Mailer.CreateQueryDef("CCspl", "PARAMETERS CostCentre Text ( 255 );SELECT MonthlyFteData.CostCentre, MonthlyFteData.EmpName, MonthlyFteData.Workload FROM MonthlyFteData WHERE (((MonthlyFteData.CostCentre)=[CostCentre]))")

    Do Until rs1.EOF

        ' Sometimes weird things happen when you reuse querydef with new parameters
        qdf.Parameters("CostCentre") = rs1.Fields("CostCentre")
        Set rs2 = qdf.OpenRecordset()

        If Not rs2.EOF Then
            Set oBook = oExcel.Workbooks.Add
            Set oSheet = oBook.Worksheets(1)

            oSheet.Range("A2").CopyFromRecordset rs2
            oBook.SaveAs "C:\Users\807140\Downloads\" & rs2.Fields("CostCentre") & ".xlsx"
        Else
            Msgbox "No Data Found for: " & rs1.Fields("CostCentre") 
            Exit Do
        End If

        rs2.Close

        Set rs2 = Nothing
        Set oBook = Nothing     
        Set oSheet = Nothing        

        rs1.MoveNext
    Loop

    oExcel.Quit

    qdf.Close
    rs1.Close
    Mailer.Close

    Set qdf = Nothing
    Set rs1 = Nothing
    Set Mailer = Nothing

    ' Remove Excel references
    Set oBook = Nothing
    Set oSheet = Nothing
    Set oExcel = Nothing

End Sub