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.

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:

## 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.

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

' 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.Select``````

End 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.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
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 = Nothing``````

End 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 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
' 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
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.Select``````

End 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.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.
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 = Nothing``````

End Function