Question

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

data-dismiss

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

我替换了

   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

带

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

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

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

Answer 1

不要在记录集中使用For..Next循环。使用此：

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

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

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

Answer 2

3021错误（“No current record。”）出现在这两行中的第二行：

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

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

但是，仍然可以访问您在打开rs1.Fields("CostCentre")时用作查询参数的rs2值。因此，您可以通过询问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

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

3 个答案: