Excel VBA：連接中的消息框錯誤

Question

有一個網站，可以創建包含表的數千個.csv文件。 CSV文件基於用戶要求的信息。

我用VBA腳本創建了一個excel文件。 用戶將數據輸入excel文件，然后VBA腳本生成正確的URL，並嘗試從該URL中的.csv獲取所需的數據。

在我的excel文件中，用戶可以要求數百個.csv表，而我希望用戶能夠輸入他想要的數百種信息類型，然后運行VBA腳本並讓計算機進行處理。

我首先進行URL檢查，如果可以，我嘗試在該URL的.csv文件中獲取數據。

在大多數情況下，它完全可以正常工作。 適用於HttpExists返回TRUE的情況，也適用於HttpExists返回FALSE的情況（它僅跳過當前活動單元並轉到下一個單元）。

但是有幾次，URL檢查會回答URL正常（HttpExists返回TRUE），但是當嘗試獲取數據時，它會打開一個消息框，顯示“抱歉，我們無法打開'URL地址”。 （運行時錯誤1004的消息框），然后VBA腳本終止。

我想知道如何解決它。 如果出現錯誤，如何跳過當前URL，而不是顯示一個終止腳本運行的消息框？

Sub my_method()

On Error GoTo handleCancel

Dim errorFlag As Boolean



 .......

Do Until ActiveCell.Value = ""
    errorFlag = True

    URLstring= ....

    ........

        If Not HttpExists(URLstring) Then
            symbolStatus = "Data unavailable"
            logAddress = updateLog("invalid URL " & ActiveCell.Value, logAddress, debugString)
            Application.DisplayAlerts = False
            Sheets(currentSymbol).Delete
            Application.DisplayAlerts = True
        Else
            With Sheets(currentSymbol).QueryTables.Add(Connection:= _
                "TEXT;" & URLstring _
                , Destination:=Sheets(currentSymbol).Range(dataAddress))
                .Name = ""
                .FieldNames = True
                .RowNumbers = False
                .FillAdjacentFormulas = False
                .PreserveFormatting = True
                .RefreshOnFileOpen = False
                .RefreshStyle = xlOverwriteCells
                .SavePassword = False
                .SaveData = True
                .AdjustColumnWidth = True
                .RefreshPeriod = 0
                .TextFilePromptOnRefresh = False
                .TextFilePlatform = 850
                .TextFileStartRow = 2
                .TextFileParseType = xlDelimited
                .TextFileTextQualifier = xlTextQualifierDoubleQuote
                .TextFileConsecutiveDelimiter = False
                .TextFileTabDelimiter = False
                .TextFileSemicolonDelimiter = False
                .TextFileCommaDelimiter = True
                .TextFileSpaceDelimiter = False
                .TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 9)
                .TextFileTrailingMinusNumbers = True
                .Refresh BackgroundQuery:=False
            End With

  .......

    errorFlag = False
 handleCancel:
    ActiveCell.Offset(1, 0).Select

    If errorFlag = True Then
            symbolStatus = "Data unavailable"
            logAddress = updateLog("invalid URL " & ActiveCell.Value,      
                         logAddress, debugString)
            Application.DisplayAlerts = False
            Sheets(currentSymbol).Delete
            Application.DisplayAlerts = True
    End If

Loop
 End Sub




Function HttpExists(sURL As String) As Boolean
    Dim oXHTTP As Object
    Set oXHTTP = CreateObject("MSXML2.ServerXMLHTTP")

    If Not UCase(sURL) Like "HTTP:*" Then
        sURL = "http://" & sURL
    End If

    On Error GoTo haveError
    oXHTTP.Open "HEAD", sURL, False
    oXHTTP.send
    HttpExists = IIf(oXHTTP.status = 200, True, False)
    Exit Function

haveError:
    HttpExists = False
End Function

有時會出現“運行時錯誤1004”消息框，並且發生在以下行中：

        With Sheets(currentSymbol).QueryTables.Add(Connection:= _
            "TEXT;" & URL _

我希望只是在出現錯誤的情況下跳過當前單元格，然后繼續下一個單元格，而無需任何消息框且不會崩潰。

我該如何解決？

謝謝

Answer 1

您需要在代碼中添加錯誤處理。 服務器超時通知並不反映您的編碼問題，而是服務器問題（除非您輸入了錯誤的URL，否則這是您無法控制的）。

在您的代碼中，您需要將On Error GoTo ErrHandler ，確保您擁有錯誤號，並且由於您只想恢復到下一個單元格，因此可以執行以下操作：

Sub Test()
    On Error GoTo ErrHandler

    'Your code

    Exit Sub
ErrHandler:
    If Err.Number = 123456 Then
        'Get the code ready for the next cell, if necessary
        Resume Next
    Else
        'Other Errs
    End If
End Sub

Answer 2

查看此錯誤處理結構是否更好地工作。 我消除了不必要的部分，並調整了應該工作的部分，但是我不確定.....節中的代碼是什么。 無論如何，這至少應該使您有一個大致的了解。 我評論了幾件事，以便在代碼中更清楚地解釋。

Option Explicit

Sub my_method()

    Do Until ActiveCell.Value = ""

        'URLstring= ....

        If Not HttpExists(URLstring) Then

            LogError 'create sub since you do same thing twice

        Else

            On Error GoTo handleBadURL 'now is only time you need to move to actual error handling

            With Sheets(currentSymbol).QueryTables.Add(Connection:= _
                "TEXT;" & URLstring _
                , Destination:=Sheets(currentSymbol).Range(dataAddress))
                .Name = ""
                .FieldNames = True
                .RowNumbers = False
                .FillAdjacentFormulas = False
                .PreserveFormatting = True
                .RefreshOnFileOpen = False
                .RefreshStyle = xlOverwriteCells
                .SavePassword = False
                .SaveData = True
                .AdjustColumnWidth = True
                .RefreshPeriod = 0
                .TextFilePromptOnRefresh = False
                .TextFilePlatform = 850
                .TextFileStartRow = 2
                .TextFileParseType = xlDelimited
                .TextFileTextQualifier = xlTextQualifierDoubleQuote
                .TextFileConsecutiveDelimiter = False
                .TextFileTabDelimiter = False
                .TextFileSemicolonDelimiter = False
                .TextFileCommaDelimiter = True
                .TextFileSpaceDelimiter = False
                .TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 9)
                .TextFileTrailingMinusNumbers = True
                .Refresh BackgroundQuery:=False
            End With

            On Error Go To 0 'reset error handling (doesn't matter so much here, but good practice to always reset when not needed

        End If

        ActiveCell.Offset(1, 0).Select

    Loop

Exit Sub 'leave sub when all is done (so it doesn't move to error handling code below

handleBadURL:

        LogError 'created sub since you do same thing twice
        Resume Next 'this statement will allow code to continue from point of error onward (the loop will keep going

 End Sub


Sub LogError()

    symbolStatus = "Data unavailable"
    logAddress = updateLog("invalid URL " & ActiveCell.Value, logAddress, debugString)
    Application.DisplayAlerts = False
    Sheets(currentSymbol).Delete
    Application.DisplayAlerts = True

End Sub