Excel VBA：连接中的消息框错误

Question

There is a website, that can create thousands of .csv files that contain tables. The CSV files are based on the information the user asks.

I created an excel file with VBA script. The user enters the data to the excel file, then the VBA script generates the correct URL, and tries to get the required data from the .csv in that URL.

In my excel file, the user can ask for hundreds of .csv tables, and I want the user to be able to enter the hundreds of information kinds he wants, then run the VBA script and leave the computer to work on it.

I first do URL check, and if it is ok, I try to get the data in the .csv file in that URL.

most of the times, it works completely fine. Works fine for a case when HttpExists returns TRUE, and also works fine for a case that HttpExists returns FALSE (it just skips the current active cell and goes to the next one).

But there are a few times, that the URL check answers that the URL is fine (HttpExists returns TRUE), but when it tried to get the data, it opens a message box that says "sorry, we couldn't open 'url address' ". (message box for Run Time Error 1004) and then the VBA scripts terminates.

I would like to know how can I fix it. How can I just skip the current URL in case of error, instead of showing a message box that terminates the script run?

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

It sometimes goes out with a messagebox of Run Time Error 1004, and it happens in the line of:

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

I would like it just to skip the current cell in a case of error, and go on with the next cell, without any messagebox and without crashing.

How can I fix it?

Thanks

Answer 1

You need to add error handling to your code. Server timeout notices doesn't reflect an issue with your coding, but an issue with the server (which is out of your control, unless of course, you entered an incorrect URL).

In your code, you need to place On Error GoTo ErrHandler , make sure you have the error number, and since you are wanting to just resume to the next cell you can do something like this:

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

See if this error handling structure works better. I eliminated parts that are unnecessary and adjusted to what should work, but I am not sure what code is in the ..... sections. Anyway, this should at least give you a general understanding. I commented a few things to explain more clearly in code.

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