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

Question

我正在尝试将多个数据集导出到相应的新 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 的适当记录数。

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

Answer 1

不要将For..Next 循环与记录集一起使用。使用这个：

Do While Not rs1.EOF
    ' do stuff with rs1
    rs1.MoveNext
Loop
rs1.close

正如 Ryan 所写，Dim 不属于任何循环，将它们移动到子的开头。

如果这没有帮助，请告诉我们错误发生在哪一行。

Answer 2

3021 错误（“没有当前记录。”）出现在这两行的第二行：

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

这是因为rs2 记录集指针在您执行CopyFromRecordset rs2 之后位于EOF。然后在SaveAs，您要求rs2.Fields("CostCentre")，但是当记录集指针位于EOF 时，没有可用记录（“无当前记录”）。

但是，您在打开 rs2 时用作查询参数的 rs1.Fields("CostCentre") 值仍然可以访问。因此，您可以通过请求 rs1.Fields("CostCentre") 而不是 rs2.Fields("CostCentre") 来消除错误

oBook.SaveAs "C:\Users\807140\Downloads\" & rs1.Fields("CostCentre") & ".xlsx"

Answer 3

此代码存在@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