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 얻을 -

내가

Debug.Print .RecordCount 

으로

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

교체되어 현재 레코드 없음을 그리고 사실에 대한 적절한 레코드 수를받을 수 있나요 rs2.

어떻게 코드를 수정하여 오류를 제거 할 수 있습니까?

Answer 1

이 코드에는 @Andre와 Ryan이 지적한 몇 가지 문제점이 있습니다.

Excel 객체를 재사용하지 않으므로 한 번만 정의해야하는 객체를 다시 디밍하는 반면 참조되지 않는 With는 이점이없는 코드를 추가합니다.

또한 매개 변수 쿼리를 SQL로 작성하고 이름으로 다시 사용할 수 있도록 저장하는 대신 코드로 작성합니다.

이 재 작성된 코드를 사용해보고 더 잘 작동하는지 확인할 수 있습니다. 사전 정의 된 쿼리가 더 좋은 방법이라고 생각합니다. 그런 다음 루프 내에서 쿼리를 닫고 매번 시작시 재설정합니다. querydefs가 루프를 다시 설정하지 않고 루프 내에서 다시 사용할 때 이상한 일이 발생하는 것을 보았습니다. (". 없음 현재 레코드"을) -

어쨌든 이것은을 시도주고 오류를

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 

Answer 2

레코드 집합에 For..Next 루프를 사용하지 마십시오.

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

을 그리고 라이언이 쓴, Dim은 어떤 루프에 속하는 하위의 시작으로 이동하지 않습니다 사용합니다.

도움이되지 않는 경우 오류가 발생한 행을 알려주십시오.

Answer 3

(3021) 오류가 발생합니다 특정 라인을보고이 두 라인의 두 번째 발생 :

rs2 레코드 포인터가 EOF에 있기 때문에 발생

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

너는 CopyFromRecordset rs2을해라. 그런 다음 SaveAs에서 rs2.Fields("CostCentre")을 요청하지만 레코드 세트 포인터가 EOF 일 때 사용할 수있는 레코드가 없습니다 ("현재 레코드가 없습니다").

rs2을 열 때 검색어 매개 변수로 사용했던 rs1.Fields("CostCentre") 값에 계속 액세스 할 수 있습니다.그래서 당신은 오류가 요청에 의해 멀리 갈 수 rs1.Fields("CostCentre") 대신

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