运行时错误“-2147417848 (80010108)”：方法“打开”对象的 _记录集'失败 - 将 Excel 与 ADO 连接结合使用

Question

我正在使用我在 Excel 2013 中开发的宏。根据条件（SQL），它将从 Excel 文件中获取数据并写入另一个 Excel 文件。它创建 11 个文件（通过 For 和 Next 循环）。如果它获取每个条件的记录，它就会打包每个文件。

它大部分工作正常。有几次它会抛出错误“运行时错误‘-2147417848 (80010108)’：对象‘_Recordset’的方法‘打开’失败”。检查了我的代码，没有发现任何错误。到目前为止，我所做的就是关闭宏并重新运行，它将顺利创建文件而不会出现错误。很少有第二次也会显示相同的错误。但是，当我关闭并打开宏文件并运行时，我得到的结果没有任何错误。

需要指导来永久解决这个问题。附上目前的VBA代码并请求专家帮助。

错误出现在此代码行上 - rs.Open strQuery、objCon、adOpenStatic、adLockBatchOptimistic

代码 -

Sub ReceivedReports(ByVal strConString As String) Dim intA 作为整数，intB 作为整数，intRecCount 作为双精度 Dim lngRecCount As Long '生成待发送文件 Pending_Date = 格式（日期 - 1，“DD-MMM-YYYY”） strRegionCode = "APRSTSKL0102KAMHMPNRUP" intCount = Len(strRegionCode) / 2

For IntI = 1 To intCount
    StrRegion = Mid(strRegionCode, (IntI * 2) - 1, 2)
    If StrRegion = "01" Then
        StrRegion = "TN01"
    End If
    If StrRegion = "02" Then
        StrRegion = "TN02"
    End If

    'Set the new instance of Connection and Recordset
    Set objCon = New ADODB.Connection
    Set rs = New ADODB.Recordset

    'Open the Connection
    With objCon
        .ConnectionTimeout = 0
        .CommandTimeout = 0
        .Open strConString
    End With

    'Set the SQL Query
    'Things to note here: Sheet1 is the name of the sheet which needs to be followed by $ in the query
    If IntI <= 7 Then
        strQuery = "Select [Region], [Branch], [Prod], [AgNo], [PartyName], [AgDate], [BizMon],  [Hub], [FileStatus], [RecdDate] from [Sheet1$] where [Region] = '" & StrRegion & "' And [FileStatus] = 'Received' Order By [RecdDate], [Branch]"
    Else
        strQuery = "Select [Region], [Branch], [Prod], [AgNo], [PartyName], [AgDate], [BizMon],  [Hub], [FileStatus], [RecdDate], [State] from [Sheet1$] where [Region] = '" & StrRegion & "' And [FileStatus] = 'Received' Order By [RecdDate], [Branch]"
    End If
    'Run the SQL query and store the result in rs variable
    If rs.State = 1 Then rs.Close
    rs.Open strQuery, objCon, adOpenStatic, adLockBatchOptimistic
    Dim counter As Integer, newWbk As Workbook
    lngRecCount = rs.RecordCount
    If rs.RecordCount > 0 Then
        Set newWbk = Workbooks.Add
        'Put headers
        With newWbk.Sheets("Sheet1")
            For counter = 0 To rs.Fields.Count - 1
                .Cells(2, 2 + counter).Value = rs.Fields(counter).Name
            Next counter
        End With
        
        'Paste Data from RecordSet
        newWbk.Sheets("Sheet1").Range("B3").CopyFromRecordset rs
        'save this workbook as a location
        TargetFile = "\Received Scan Pending Files As On " & " - " & Format(Pending_Date, "DD-MMM-YYYY") & " - " & StrRegion & ".xlsx"
        With ActiveSheet
            .Cells.Font.Size = 10
            .Cells.Font.Name = "Verdana"
        End With
        Worksheets("Sheet1").Columns("A").ColumnWidth = 5
        Worksheets("Sheet1").Columns("F").ColumnWidth = 30
        newWbk.Sheets("Sheet1").Range("G:G").NumberFormat = "DD-MMM-YYYY"
        newWbk.Sheets("Sheet1").Range("K:K").NumberFormat = "DD-MMM-YYYY"
        newWbk.Sheets("Sheet1").Range("A:XFD").Interior.ColorIndex = 2
        'Put Border for Data Used Range
        With ActiveSheet.UsedRange.Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
            .Color = RGB(0, 0, 255)     'Blue Color
        End With
        'Update Hub Name
        If IntI >= 7 Then
            intLastRow = ActiveSheet.UsedRange.Rows.Count
            For intA = 3 To intLastRow + 1
                strHubCode = ActiveSheet.Cells(intA, 9)
                For intB = LBound(StrHubData) To UBound(StrHubData)
                    If StrHubData(intB, 0) = strHubCode Then
                        strHubName = StrHubData(intB, 1)
                        ActiveSheet.Cells(intA, 9).Cells.Value = strHubName
                        Exit For
                    End If
                Next intB
            Next intA
        End If
        Worksheets("Sheet1").Range("A1").RowHeight = 25
        StrRep = "R"
        Call PivotTable
        ActiveWorkbook.SaveAs Application.DefaultFilePath & TargetFile
        TargetFile = Application.DefaultFilePath & TargetFile
        ActiveWorkbook.Close
    End If
    rs.Close 'Close the connect
    Set rs = Nothing 'Release the variable from memory
    objCon.Close 'Close the RecordSet
    Set objCon = Nothing 'Release the variable from memory
    If lngRecCount > 0 Then
        strDataSource = "C:\Users\sram\Documents\ControlData.xlsx"
        Set wbk = Workbooks.Open(strDataSource)
        Set sht = wbk.Sheets("EMail")
        intLastRow = sht.Cells(Rows.Count, "B").End(xlUp).Row
        sht.Cells(intLastRow + 1, 2).Value = StrRegion
        sht.Cells(intLastRow + 1, 3).Value = "RAP"
        sht.Cells(intLastRow + 1, 4).Value = TargetFile
        wbk.Close savechanges:=True
    End If
Next IntI

End Sub

Answer 1

当错误是由 VBA/Excel 环境之外的条件引起时（可能就是这里的情况），我将捕获错误，等待一小会儿，然后重试。尝试替换：

rs.Open strQuery, objCon, adOpenStatic, adLockBatchOptimistic

我

Dim waitSeconds As Integer
waitSeconds = 1 'how many seconds to start waiting if there is a problem.  This will increase the after each failed attempt
On Error Resume Next 'if there is an error, just move on
Do ' a loop to try again if the recordset fails to open
    rs.Open strQuery, objCon, adOpenStatic, adLockBatchOptimistic
    If Err.Number = 0 Then Exit Do ' if there is no error, exit the loop
    Debug.Print "Recordset failed.  Trying again in " & waitSeconds & " seconds"
    If waitSeconds > 9 Then ' a way to give up trying if wait seconds gets to big
          Debug.Print "Hmmm.  That's too long to wait.  Giving up... "
          Stop ' halt the execution of the script
    End If
    Application.Wait (Now + TimeValue("0:00:" & waitSeconds)) ' pause for waitseconds
    waitSeconds = waitSeconds * 1.5 ' increase the number of seconds to wait for the next time
    DoEvents ' allow the user to interrupt the loop with ctrl-break
Loop
On Error GoTo 0 ' resume normal behavior when a runtime error happens

添加了注释来解释它的每个部分的作用，但如果您有疑问，请随时在评论中提问。

基本上，此代码尝试打开记录集。如果成功（err.number=0），那么我们就跳出循环。如果没有，我们等待 waitSeconds，然后将等待秒数增加 50%，这样如果下次尝试失败，它会等待更长时间。然后我们再试一次。