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.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.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 = Nothing
End Function
' URL Encoding function courtesy of
How can I URL encode a string in Excel VBA? - Stack Overflow
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.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.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 = Nothing
End Function
