excel - 如何使用网站加快 VBA 脚本的处理速度？

Question

我有一个 VBA 脚本，可以让我计算两个城市之间的公里距离:

这个脚本工作正常，问题是我得到的要计算的城市列表超过 5000 个城市。
当我按下“开始”按钮时，处理开始，Excel 文件卡住，在处理完成之前无法查看处理进度，大约需要 1 小时......
是否可以提高我的脚本的处理速度，还是因为我的互联网连接速度？
由于处理时间过长，脚本从大约 3000 个城市停止。我该如何解决这个问题？

Option Explicit

Public Const DIST = "http://www.distance2villes.com/recherche?source="


Sub Distance()
Dim lg As Integer, i As Integer
Dim Url As String, Txt As String

    With Sheets("Feuil1")
        lg = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = 2 To lg
            Url = DIST & .Range("A" & i).Value & "&destination=" & .Range("B" & i).Value
            With CreateObject("WINHTTP.WinHTTPRequest.5.1")
                .Open "GET", Url, False
                .send
                Txt = .responseText
            End With
            
            ' Only set the value if we got a response
            If Txt <> vbNullString Then .Range("C" & i).Value = Split(Split(Txt, "id=""distanciaRuta"">")(1), "</strong>")(0)

            ' Clear our variable before next
            Txt = vbNullString
        Next i
    End With
End Sub

Answer 1

GetElementById(与双拆分)

这里的问题是该网站正在生成巨大的网页，这取决于城市之间的距离，例如Paris-London 生成大约 90k 个字符的字符串，而 Paris-Vladivostok 生成 1.4M 个字符。

使用不同的对象 (MSXML2.XMLHTTP) 将效率提高了大约 10%。

代码

Option Explicit

Sub Distance()
    
    Const DIST1 As String = "http://www.distance2villes.com/recherche?source="
    Const DIST2 As String = "&destination="
    Const DIST3 As String = "distanciaRuta"
    Const wsName As String = "Feuil1"
    
    'Dim w As Object: Set w = CreateObject("WINHTTP.WinHTTPRequest.5.1")
    Dim w As Object: Set w = CreateObject("MSXML2.XMLHTTP")
    Dim h As Object: Set h = CreateObject("htmlfile")
    
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(wsName)
    Dim rg As Range
    Set rg = ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(, 1))
    Dim Data As Variant: Data = rg.Value
    
    Dim isFound As Boolean: isFound = True
    Dim i As Long
    Dim Url As String
    Dim S As String
    
    For i = 1 To UBound(Data, 1)
        If Len(Data(i, 1)) > 0 And Len(Data(i, 2)) > 0 Then
            Url = DIST1 & Data(i, 1) & DIST2 & Data(i, 2)
            w.Open "GET", Url, False
            w.Send
            h.body.innerHTML = w.responseText
            On Error GoTo NotFoundError
            S = h.getElementById(DIST3).innerText
            On Error GoTo 0
            If isFound Then
                Data(i, 1) = Replace(Left(S, Len(S) - 3), ",", "")
            Else
                Data(i, 1) = ""
                isFound = True
            End If
        Else
            Data(i, 1) = ""
        End If
    Next
    rg.Columns(1).Offset(, 2).Value = Data
    
    Exit Sub

NotFoundError:
    isFound = False
    Resume Next

End Sub