# performance – Calculate the distance in km between two cities in the world in VBA

I have a VBA script that works well, it allows me to calculate the distance between two cities by specifying the country in question based on this site:

`http://www.distance2villes.com/recherche?source=` I have sometimes more than 8000 distances to calculate, I would like to know if you have any advice to improve my script and its processing speed for the many distances?

``````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
``````

Posted on Categories Articles