Рассчитайте расстояние в км между двумя городами мира в VBA

У меня есть сценарий VBA, который работает хорошо, он позволяет мне рассчитать расстояние между двумя городами, указав страну, о которой идет речь, на основе этого сайта:

http://www.distance2villes.com/recherche?source=

Иногда мне нужно вычислить более 8000 расстояний, я хотел бы знать, есть ли у вас какие-либо советы по улучшению моего скрипта и скорости его обработки для многих расстояний?

Option Explicit

Function correct(ByVal city As String) As String
    Dim i As Long
    'a) change special cities to French spelling
    Dim cities: cities = Split("ROMA TRIGORIA,S BENEDETTO D TRONTO,AN BREUKELE,MILTON KEY,COPENHAGEN V,PULA CA,051 BALEAL,BRANCA CCH,ST GILLES CROIX DE V,559 PENICHE,WOLKA KRAKOWSKA,L AQUILA,FIUMINCINO,SESTO FLORENTINO,EUPILO", ",")
    Dim cities2: cities2 = Split("Rome,San Benedetto del Tronto,Breukelen,Milton Keynes,Copenhague,Pula,Baleal,Branca,Saint-Gilles-Croix-de-Vie,Peniche,Wola Kosowska,L'Aquila,Fiumicino,Sesto Fiorentino,Eupilio", ",")
    For i = 0 To UBound(cities)
        city = Replace(city, cities(i), cities2(i))
    Next
    'b)remove numeric district suffixes
    Dim tmp: tmp = Split(city, " ")
    If IsNumeric(tmp(UBound(tmp))) Then
        tmp(UBound(tmp)) = "DELETE"
        city = Join(Filter(tmp, "DELETE", False))
    End If
    'c) insert hyphens and apostrophs
    city = Replace(Replace(Replace(UCase(city), " L ", " L'"), " D ", " D'"), " ", "-")
    'd) remove all accents
    Dim chars:     chars = Split("Á À Â Ç É È Ê Î Ï")
    Dim chars2: chars2 = Split("A A A C E E E I I")
    For i = 0 To UBound(chars)
        city = Replace(city, chars(i), chars2(i))
    Next
    'e) return function result
    correct = city
End Function


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(, 2))
    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
          'Line to take into account the city of departure and arrival with its country
            Url = DIST1 & Data(i, 1) & DIST2 & correct(Data(i, 2)) & "%20" & Data(i, 3)
            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(, 3).Value = Data
    
    Exit Sub

NotFoundError:
    isFound = False
    Resume Next

End Sub