Speeding up Excel distance calculation using Bing API calls

Question

I am writing VBA in Excel to calculate the distance between an employee's home address and work address using Bing Maps API calls. The process follows this general flow:

1) Convert the employee's address to Lat-Long values using the GetLatLong function

2) Convert the employee's work address to Lat-Long values using the GetLatLong function

3) Calculate the distance between these two points using the GetDistance function

4) Calculate the drive time between these two points using the GetTime function

The spreadsheet looks like this:

The process is working, but it is excruciatingly slow. The employee population is approximately 2300, and it takes almost an hour to execute.

I am not a coder, but I can functionally modify found code to my purposes. This is an amalgamation of multiple different processes found through Google searches. The code pieces in use are:

Public Function GetDistance(start As String, dest As String)
    Dim firstVal As String, secondVal As String, lastVal As String
    firstVal = "https://dev.virtualearth.net/REST/v1/Routes/DistanceMatrix?origins="
    secondVal = "&destinations="
    lastVal = "&travelMode=driving&o=xml&key=<My Key>&distanceUnit=mi"
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    Url = firstVal & start & secondVal & dest & lastVal
    objHTTP.Open "GET", Url, False
    objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
    objHTTP.send ("")
    GetDistance = Round(WorksheetFunction.FilterXML(objHTTP.responseText, "//TravelDistance"), 0) & " miles"
End Function

Public Function GetTime(start As String, dest As String)
    Dim firstVal As String, secondVal As String, lastVal As String
    firstVal = "https://dev.virtualearth.net/REST/v1/Routes/DistanceMatrix?origins="
    secondVal = "&destinations="
    lastVal = "&travelMode=driving&o=xml&key=<My Key>&distanceUnit=mi"
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    Url = firstVal & start & secondVal & dest & lastVal
    objHTTP.Open "GET", Url, False
    objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
    objHTTP.send ("")
    GetTime = Round(WorksheetFunction.FilterXML(objHTTP.responseText, "//TravelDuration"), 0) & " minutes"
End Function

Public Function GetLatLong(address As String, city As String, state As String, zip As String)
    Dim firstVal As String, secondVal As String, thirdVal As String, fourthVal As String, lastVal As String
    firstVal = "https://dev.virtualearth.net/REST/v1/Locations?countryRegion=United States of America&adminDistrict="
    secondVal = "&locality="
    thirdVal = "&postalCode="
    fourthVal = "&addressLine="
    lastVal = "&maxResults=1&o=xml&key=<My Key>"
    Url = firstVal & state & secondVal & city & thirdVal & zip & fourthVal & address & lastVal
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    objHTTP.Open "GET", Url, False
    objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
    objHTTP.send ("")
    GetLatLong = WorksheetFunction.FilterXML(objHTTP.responseText, "//Point//Latitude") & "," & WorksheetFunction.FilterXML(objHTTP.responseText, "//Point//Longitude")
End Function

To be clear, the process works well, just extremely slowly. Any thoughts on speeding this up?

Answer 1

Depending on what you want to return you can actually leverage just one API method from Bing to retrieve the data you are after, the Driving Route API. Also, as others have pointed out what's killing performance is the synchronous code.

What I've done below is limited the pull to a single request, and made the code asynchronous.

I've also changed this code to a sub, as I'd need to iterate over some sort of collection. For ease of use, I used a range.

I've structured my data as the from address being in the first column of the range, and the destination address being in the column immediately after that. Travel Distance and Travel Duration will be output offset relative to the from address (2 and 3 columns offset respectively).

I did a quick benchmark, this is taking just over 4 seconds for 250 requests. Hope it helps!

Option Explicit

Const BaseURL As String = "http://dev.virtualearth.net/REST/V1/Routes/Driving?wp.0="
Const APIKey  As String = "YOUR_KEY"
Private Const READYSTATE_COMPLETE  As Long = 4

Public Sub GetDistances(Addresses As Range)
    Dim Server           As Object
    Dim ServerItem       As Variant
    Dim Servers          As Object
    Dim Cell             As Range
    Dim URL              As String

    Set Servers = CreateObject("Scripting.Dictionary")

    'Send all the requests up front, but don't wait for them to complete
    For Each Cell In Addresses
        'See here: https://docs.microsoft.com/en-us/bingmaps/rest-services/examples/driving-route-example for more details on this api
        URL = BaseURL & Cell & "&wp.1=" & Cell.Offset(0, 1) & "&key=" & APIKey & "&DistanceUnit=mi&DurationUnit=min&output=xml"
        Set Server = CreateObject("MSXML2.ServerXMLHTTP")
        Server.Open "GET", URL, True 'Last param will make request async
        Server.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
        Server.send ("")
        Servers.Add Cell.Address, Server
    Next

    'Iterate each XML request sent to see if done
    For Each ServerItem In Servers.Keys()
        Set Server = Servers(ServerItem)

        While Server.readyState <> READYSTATE_COMPLETE
            DoEvents
        Wend

        'Parse result
        If Server.Status = 200 Then
            'Add result to the sheet to an offsetting column
            Addresses.Parent.Range(ServerItem).Offset(0, 2) = WorksheetFunction.FilterXML(Server.ResponseText, "/Response/ResourceSets/ResourceSet/Resources/Route/TravelDistance")
            Addresses.Parent.Range(ServerItem).Offset(0, 3) = WorksheetFunction.FilterXML(Server.ResponseText, "/Response/ResourceSets/ResourceSet/Resources/Route/TravelDuration") / 60
            'You can also return the lat/long from this request, see --> https://docs.microsoft.com/en-us/bingmaps/rest-services/examples/driving-route-example
        End If
    Next

End Sub

Sub ProcessData()
    Dim myRng As Range
    Dim t As Double
    t = Timer
    Set myRng = ThisWorkbook.Sheets(1).Range("A1:a250")
    GetDistances myRng
    Debug.Print Timer - t
End Sub

Answer 2

GetTime and GetDistance look very, very similar. In fact, they're identical, save for how the XML response is parsed:

Public Function GetDistance(start As String, dest As String)
    '...
    GetDistance = Round(WorksheetFunction.FilterXML(objHTTP.responseText, "//TravelDistance"), 0) & " miles"
End Function

Public Function GetTime(start As String, dest As String)
    '...
    GetTime = Round(WorksheetFunction.FilterXML(objHTTP.responseText, "//TravelDuration"), 0) & " minutes"
End Function

This is great news: it means there's an opportunity to slash the total execution time by a third, by reducing the number of REST API calls you need to wait for by as much.

The first step is to remove all redundancies. Ultimately we want the 3 functions to look something like this:

Public Function GetDistance(ByVal start As String, ByVal dest As String) As Double
    GetDistance = VirtualEarthAPI.DistanceMatrix(start, dest).Distance
End Function

Public Function GetTravelTime(ByVal start As String, ByVal dest As String) As Date
    GetTravelTime = VirtualEarthAPI.DistanceMatrix(start, dest).TravelTime
End Function

Public Function GetLatLong(ByVal address As String, ByVal city As String, ByVal state As String, ByVal zip As String) As String
    GetLatLong = VirtualEarthAPI.LocationPoint(address, city, state, zip)
End Function

Note that the GetDistance function now return a Double, and leave the formatting of that numeric value up to the client (i.e. the worksheet) - knowing that a number representing distance in miles needs to look like 123.45 miles is a concern for the consumer of this function, not the function itself. As a bonus with the distances now understood as the numeric values they are by Excel, you can do math on these numbers and calculate average distances if you need to. The NumberFormat for distance could be #,##0.00 "miles", for example.

Same with GetTravelTime: by returning a Date (using the VBA.DateTime.TimeSerial function to build it from the number of minutes returned by the API), you can have a NumberFormat for these values that looks like hh:mm, and now Excel can perform math on these values, too.

You have all parameters implicitly passed by reference (ByRef), but they should all be passed by value (ByVal); the functions' return type was also implicitly Variant - specifying an explicit return type makes a much cleaner API to use, especially if any VBA code needs to invoke these functions.

You could use a Scripting.Dictionary to cache the responses for DistanceMatrix, keyed with {start}->{dest} strings that would be easy to lookup from the start and dest arguments: if the dictionary contains that key, you return the cached response; otherwise, you make the HTTP request, cache the response, and return it.

But that's still synchronous, and while caching DistanceMatrix responses would essentially cut 33% of the total update time, we're still looking at almost 40 minutes (extrapolated from "almost an hour") to update, which makes it a lot of work for relatively little gain. The biggest win would be to change the strategy entirely, and replace the user-defined functions with a macro, which might look like this:

Option Explicit
Private macro As New EmployeeTableUpdaterMacro

Public Sub UpdateEmployeeTableAsync()
    macro.ExecuteAsync
End Sub

The logic would need to move to a new EmployeeTableUpdaterMacro class module that exposes a Public Sub ExecuteAsync() procedure and proceeds to update the data in the employee table using asynchronous HTTP requests, i.e. updating the values as they come, possibly while displaying a progress indicator (or updating the Application.StatusBar) showing how many requests were sent vs. how many responses were received.