運行時錯誤“-2147417848 (80010108)”：對象“_Recordset”的“打開”方法失敗 - 使用 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 As Integer, intB As Integer, intRecCount As Double Dim lngRecCount As Long '生成發送待處理文件 Pending_Date = Format(Date - 1, "DD-MMM-YYYY") strRegionCode = "UPRSTSKAML0" 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

結束子

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%，以便在下一次嘗試失敗時等待更長時間。 然后我們再試一次。