My sister was looking for an easy way to calculate distances so I wrote her a couple macros that that she could use in Excel. The code is below for anyone who wants to borrow it and extend it further.
Using Google MAP APIs
Google provides a very well documented and easy to use API that is accessible through basic HTTP requests. The response it returns can be either JSON or XML format – in our case we’re using the XML format because the MSXML parser can easily parse it within an Excel Macro.
In order to use the XML parser, you need to have a reference to the Microsoft XML v6.0 COM object. In the macro editor, go under Tools –> References and make sure this component is checked. If the component isn’t in the list, you can browse to it – it should be located in the C:\Windows\System32 directory and the DLL is msxml6.dll.
Looking Up Longitude and Latitude
The objective in this scenario is pretty simple – take a list of addresses and geo-code them with longitude and latitude values.image
Google Maps API provides the ability to look up longitude and latitude:
https://maps.googleapis.com/maps/api/geocode/xml?address=New+York
Looking Up Distance
The objective in this scenario is to take a list of source and destination addresses and calculate the distance based on the shortest route that Google Maps calculates. The advantage of this approach is this factors in the specific routing through streets instead of calculating it “as the crow flies” (e.g. directly from one point to another).
Google Maps API provides the ability to look up directions and routes and provides a total distance in meters for each route.
https://maps.googleapis.com/maps/api/directions/xml?origin=Chicago&destination=Toronto
VBA Macro Code
Option Explicit
‘ Subroutine to plug in Longitude and Latitude for a range of locations.
Public Sub LookupLongitudeAndLatitude()
' Declare variables
Dim CurrentSheet As Worksheet
Dim CurrentRange As Range
Dim row As Range
Dim Address As String
Dim Longitude As Double
Dim Latitude As Double
Dim Success As Boolean
Dim BlankValues As Boolean
Dim Status As String
' Get the current selected cells
Set CurrentSheet = ActiveSheet
Set CurrentRange = Selection
' check for current range size to see if three columns are available.
If CurrentRange.Columns.Count <> 3 Then
MsgBox ("Please select 3 columns, one with addresses in it and two blank to put the long and lat values")
Else
For Each row In CurrentRange.Rows
BlankValues = True
Address = row.Cells(1, 1)
' Check for existing values. We're expecting blank for columns 2 and 3 so if they have any content,
' we'll error out and send a warning isntead of writing over existing cells.
If IsEmpty(row.Cells(1, 2)) <> True Then
MsgBox ("Expected longitude column to be blank for cell " & row.Cells(1, 2).Address(False, False))
BlankValues = False
End If
If IsEmpty(row.Cells(1, 3)) <> True Then
MsgBox ("Expected latitude column to be blank for cell " & row.Cells(1, 3).Address(False, False))
BlankValues = False
End If
If BlankValues = True Then
Success = GetLongitudeAndLatitude(Address, Longitude, Latitude, Status)
If Success = True Then
row.Cells(1, 2) = Longitude
row.Cells(1, 3) = Latitude
Else
row.Cells(1, 2) = Status
row.Cells(1, 3) = Status
End If
End If
Next row
End If
' reset selection to original range
CurrentSheet.Select
CurrentRange.SelectEnd Sub
Private Function GetLongitudeAndLatitude(Address As String, Longitude As Double, Latitude As Double, Status As String) As Boolean
' Declare variables and set return value to false by default
GetLongitudeAndLatitude = False
Dim response As DOMDocument60
Dim http As XMLHTTP60
Dim node As IXMLDOMNode
Dim nodes As IXMLDOMNodeList
Set http = New XMLHTTP60
' Read the data from the website
On Error Resume Next
' Open an XML request from Google using their GeoCode API
http.Open "GET", "https://maps.googleapis.com/maps/api/geocode/xml?address=" & URLEncode(Address), False
http.send
Set response = http.responseXML
' get the status node. This node tells you whether your search succeeded - OK means success. Any other status means some kind of error or address not found.
Set node = response.SelectSingleNode("/GeocodeResponse/status")
If node.nodeTypedValue <> "OK" Then
Status = node.nodeTypeString
Else
Set nodes = response.SelectNodes("/GeocodeResponse/result")
' check for multiple addresses if we found more than 1 result then error out.
If nodes.Length > 1 Then
MsgBox ("Found Multiple Matches for Address: " & Address)
Else
' grab the latitude and longitude from the XML response
Set node = response.SelectSingleNode("/GeocodeResponse/result/geometry/location/lat")
Latitude = node.nodeTypedValue
Set node = response.SelectSingleNode("/GeocodeResponse/result/geometry/location/lng")
Longitude = node.nodeTypedValue
GetLongitudeAndLatitude = True
End If
End If
Set http = Nothing
Set response = NothingEnd Function
‘ URL Encoding function courtesy of http://stackoverflow.com/questions/218181/how-can-i-url-encode-a-string-in-excel-vba
Private Function URLEncode( _
StringVal As String, _
Optional SpaceAsPlus As Boolean = False _
) As String
Dim StringLen As Long: StringLen = Len(StringVal)
If StringLen > 0 Then
ReDim result(StringLen) As String
Dim i As Long, CharCode As Integer
Dim Char As String, Space As String
If SpaceAsPlus Then Space = "+" Else Space = "%20"
For i = 1 To StringLen
Char = Mid$(StringVal, i, 1)
CharCode = Asc(Char)
Select Case CharCode
Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
result(i) = Char
Case 32
result(i) = Space
Case 0 To 15
result(i) = "%0" & Hex(CharCode)
Case Else
result(i) = "%" & Hex(CharCode)
End Select
Next i
URLEncode = Join(result, "")End If
End Function
‘ Subroutine to plug in Distance between two addresses.
Public Sub LookupDistance()
' Declare variables
Dim CurrentSheet As Worksheet
Dim CurrentRange As Range
Dim row As Range
Dim SourceAddress As String
Dim DestinationAddress As String
Dim Distance As Double
Dim Success As Boolean
Dim BlankValues As Boolean
Dim Status As String
' select the currently selected range
Set CurrentSheet = ActiveSheet
Set CurrentRange = Selection
' check for current range size to see if three columns are available.
If CurrentRange.Columns.Count <> 3 Then
MsgBox ("Please select 3 columns, one with source address, one with destination address and one for distance.")
Else
For Each row In CurrentRange.Rows
BlankValues = True
SourceAddress = row.Cells(1, 1)
DestinationAddress = row.Cells(1, 2)
' Check for existing values. We're expecting blank for column 3 so if it contains any content,
' we'll error out and send a warning isntead of writing over existing cells.
If IsEmpty(row.Cells(1, 3)) <> True Then
MsgBox ("Expected distance column to be blank for cell " & row.Cells(1, 3).Address(False, False))
BlankValues = False
End If
If BlankValues = True Then
Success = GetDistance(SourceAddress, DestinationAddress, Distance, Status)
If Success = True Then
row.Cells(1, 3) = Distance
Else
row.Cells(1, 3) = Status
End If
End If
Next row
End If
' reset selection to original range
CurrentSheet.Select
CurrentRange.SelectEnd Sub
Private Function GetDistance(SourceAddress As String, DestinationAddress As String, Distance As Double, Status As String) As Boolean
' Declare variables and set return value to false by default
GetDistance = False
Dim response As DOMDocument60
Dim http As XMLHTTP60
Dim node As IXMLDOMNode
Dim nodes As IXMLDOMNodeList
Set http = New XMLHTTP60
' Read the data from the website
On Error Resume Next
' Open an XML request from Google using their Directions API
http.Open "GET", "https://maps.googleapis.com/maps/api/directions/xml?origin=" & URLEncode(SourceAddress) & "&destination=" & URLEncode(DestinationAddress), False
http.send
Set response = http.responseXML
' get the status node. If it isn't OK then we have either an error or no address found.
Set node = response.SelectSingleNode("/DirectionsResponse/status")
If node.nodeTypedValue <> "OK" Then
Distance = 0
Status = node.nodeTypedValue
Else
Set nodes = response.SelectNodes("/DirectionsResponse/route")
If nodes.Length > 1 Then
' this should never happen unless alternatives=true is added on to the URL above.
MsgBox ("Found Multiple Routes for Source Address " & SourceAddress & " and Destination Address " & DestinationAddress & ".")
Else
' Grab the distance value from the XML - it's in meters so we'll divide by 1000 to convert to KM
Set node = response.SelectSingleNode("/DirectionsResponse/route/leg/distance/value")
If node Is Not Null Then
Distance = node.nodeTypedValue
Distance = Distance / 1000
GetDistance = True
End If
End If
End If
Set http = Nothing
Set response = NothingEnd Function
