Reverse GeoCode Excel Tool (1 Viewer)

Rakesh935

Registered User.
Local time
Today, 19:28
Joined
Oct 14, 2012
Messages
71
Hi All,

My team uses the attached macro enabled file to identify the geocodes for the address appended into the tool and the tool does a perfect work.

But now the requirement is in addition to the geocodes the team also needs the location address of the identified geocodes.

Need your advise in achieving the same through the attached tool.

Let me know if any further information is required.

Thanks,
Rakesh
 

Attachments

  • excel-geocoding-tool.xls
    80.5 KB · Views: 508

June7

AWF VIP
Local time
Today, 05:58
Joined
Mar 9, 2014
Messages
5,423
Opened workbook and sheets only show if I maximize to full screen. Why? I've seen this once before and was able to fix but not figuring this one out.
 

Rakesh935

Registered User.
Local time
Today, 19:28
Joined
Oct 14, 2012
Messages
71
Attaching the file again...
 

Attachments

  • excel-geocoding-tool.zip
    31.3 KB · Views: 363

June7

AWF VIP
Local time
Today, 05:58
Joined
Mar 9, 2014
Messages
5,423
Same issue. I tried converting to xlsm and still won't show sheets. Sorry, can't work with this to evaluate.
 

Rakesh935

Registered User.
Local time
Today, 19:28
Joined
Oct 14, 2012
Messages
71
Providing the code...if it could be of any help...

Modules - mGeoCode

Code:
Option Explicit

Const LATITUDECOL = 1               'column to put longitude into
Const LONGITUDECOL = 2              'column to put latitude into
Const CONFIDENCECOL = 3             'column to put confidence indicator into
Const LOCATIONCOL = 4               'column to put location info into
Const FIRSTDATAROW = 13             'rows above this row don't contain address data
Const GOOGLEMAPSLINKCOL = 7         'column to store google maps link
Const DEBUGMODEREQUESTCOL = 10      'column to store request URI if debug mode is on
Const DEBUGMODERESPONSECOL = 11     'column to store response JSON  if debug mode is on

'Global request/response variables for debugging
Dim debugMode As Boolean
Dim debugModeRequest As String
Dim debugModeResponse As String


'geocode only selected rows
Sub geocodeSelectedRows()
    
    If checkSettings = True Then
        
        Dim r
        For Each r In Selection.rows()
            If r.Row() >= FIRSTDATAROW Then
                geocodeRow (r.Row())
            End If
        Next r
            
        Application.StatusBar = False
        
    End If

End Sub

'geocode rows listed as "not found"
Sub geocodeNotFound()
    
    If checkSettings = True Then
        
        'Loop through result range and remove "not found" cells
        'This is much easier with range.replace, but the function parameters are different between win/mac, which makes it unusable for us. The joys of cross-compatibility :)
        Dim Row As Long, Column As Long
        For Row = FIRSTDATAROW To 65536
            For Column = LATITUDECOL To CONFIDENCECOL
                If Cells(Row, Column).Value = "not found" Then
                    Cells(Row, Column).Value = ""
                End If
            Next Column
        Next Row
    
        Cells(FIRSTDATAROW, LATITUDECOL).Select
        
        'Now geocode
        Dim r As Long
        For r = FIRSTDATAROW To LastDataRow()
            geocodeRow (r)
        Next r
        
        Cells(FIRSTDATAROW, LATITUDECOL).Select
        Application.StatusBar = False
        
    End If

End Sub

'geocode ALL THE ROWS!
Sub geocodeAllRows()
    
    If checkSettings = True Then
    
        Dim r As Long
        Range("A13:C65536").Select
        Selection.ClearContents
        Range("J13:j65536").Select
        Selection.ClearContents
        Cells(FIRSTDATAROW, LATITUDECOL).Select
        
        For r = FIRSTDATAROW To LastDataRow()
            geocodeRow (r)
        Next r
        
        Application.StatusBar = False
       
    End If
    
End Sub

'geocode a single row of data
Sub geocodeRow(r As Long)
    Dim rawGeocodeData As String
    Dim geocodeData
    Dim latitude As String
    Dim longitude As String
    Dim confidence As String
    
    Application.StatusBar = "Geocoding row: " & r
    
    'can't geocode if no address data
    'nonblank latitude means we've already geocoded this row
    If Cells(r, LOCATIONCOL) <> "" And Cells(r, LATITUDECOL) = "" Then
    
        ' pass the location to geocode
        ' bingAddressLookup returns an array containing the lat/long/confidence
        rawGeocodeData = bingAddressLookup(CStr(Cells(r, LOCATIONCOL)))
        
        geocodeData = Split(rawGeocodeData, "|")
        
        'set lat/long/confidence
        latitude = geocodeData(0)
        longitude = geocodeData(1)
        confidence = geocodeData(2)
        
        'if lat/long/confidence is blank, consider it not found
        If latitude = "-" Then latitude = "not found"
        If longitude = "-" Then longitude = "not found"
        If confidence = "-" Then confidence = "not found"

        ' store the results
        Cells(r, LATITUDECOL) = latitude
        Cells(r, LONGITUDECOL) = longitude
        Cells(r, CONFIDENCECOL) = confidence
        
        'add google maps link
        If Cells(r, LATITUDECOL) <> "not found" Then
            Cells(r, GOOGLEMAPSLINKCOL).Value = "=HYPERLINK(""http://maps.google.com/maps?f=q&hl=en&geocode=&q=" & latitude & "," & longitude & """)"
        End If
        
        'add logs if enabled
        If debugMode = True Then
            Cells(r, DEBUGMODEREQUESTCOL).Value = debugModeRequest
            Cells(r, DEBUGMODERESPONSECOL).Value = debugModeResponse
            Cells(r, DEBUGMODERESPONSECOL).WrapText = False
        End If
        
    End If
    
End Sub

'Perform REST lookup on Bing
Function bingAddressLookup(location As String) As String
    On Error Resume Next
    Dim bing As New cBingMapsRESTRequest
    Dim geocodeData As String

    Application.StatusBar = "Looking for " & location
    
    'perform the lookup
    geocodeData = bing.performLookup(location)
    
    'log response/request
    If (debugMode) Then
        debugModeRequest = bing.getRequestURI
        debugModeResponse = bing.getResponseXML
    End If
    
    'return the lat/long/confidence
    bingAddressLookup = geocodeData
    
End Function

'check that all settings are valid
Function checkSettings()
   
    'Check if Bing is selected as geocoder and API key is not blank
    If Range("GeocoderToUse") = "Bing" Then
        If Range("bingMapsKey") <> "" Then
            
            'Set debug mode flag if setting is enabled
            If Range("DebugMode") = "On" Then
                debugMode = True
            Else
                debugMode = False
            End If
            
            'Ready to Geocode
            checkSettings = True
        
        Else
            MsgBox "Please enter a Bing Maps Key for geocoding"
            'Not ready to geocode
            checkSettings = False
        End If
        
    End If

End Function

Sub ClearDataEntryArea()
    Range("A13:K65536").Select
    Selection.ClearContents
    Range("A13").Select
End Sub

Private Function max(a, B):
    If a > B Then
        max = a
    Else
        max = B
    End If
End Function

' locate the last row containing address data
Function LastDataRow() As Integer
    Dim r As Long
    Dim activecelladdr As String
    
    activecelladdr = ActiveCell.Address

    Range("d65536").End(xlUp).Select
    r = ActiveCell.Row()
    Range("e65536").End(xlUp).Select
    r = max(r, ActiveCell.Row())
    Range("f65536").End(xlUp).Select
    r = max(r, ActiveCell.Row())
    Range("g65536").End(xlUp).Select
    r = max(r, ActiveCell.Row())
    
    Range(activecelladdr).Select
    LastDataRow = r
End Function

'Ensure that macros are working properly
Sub MacrosWorking()
    MsgBox "Macros are enabled."
End Sub
---------------------------------------------------------------
Class Modules - cBingMapsRESTRequest

Code:
Option Explicit

'the URL to perform the request to
Public url As String

'the response xml
Public xml As String

'performs a REST lookup to Bing location service and parses the XML
Public Function performLookup(location As String)
    Dim data(2) As String
    
    url = ("http://dev.virtualearth.net/REST/v1/Locations?query=" & URLEncode(location, True) & "&maxResults=1&key=" & Trim(CStr(Range("bingMapsKey"))) & "&o=xml")
    
    'perform an HTTP GET
    xml = HTTPGET(url)
        
    'parse the XML to get the lat/long/confidence, note for Bing, this is only "high" / "medium" / "low" vs. numerical precision indicators like Yahoo or Google
    If (InStr(xml, "<Latitude>") <> 0 And InStr(xml, "<Longitude>") <> 0 And InStr(xml, "<Confidence>") <> 0) Then
        data(0) = getElementValue("Latitude")
        data(1) = getElementValue("Longitude")
        data(2) = getElementValue("Confidence")
    Else
        data(0) = "-"
        data(1) = "-"
        data(2) = "-"
    End If
    
    performLookup = Join(data, "|")
    
End Function

'return the request URI
Public Function getRequestURI()
    getRequestURI = url
End Function

'return the response XML
Public Function getResponseXML()
    getResponseXML = xml
End Function

'wrapper for the REST request to check proxy/OS
Public Function HTTPGET(url As String) As String
    Dim useProxy As Boolean
    
    If Range("UseProxy") = "Yes" Then
        useProxy = True
    Else
        useProxy = False
    End If

    If (isWindows()) Then
        HTTPGET = windowsHTTPGET(url, useProxy)
    Else
        HTTPGET = macHTTPGET(url, useProxy)
        
    End If

End Function

'perform the REST request on windows
Private Function windowsHTTPGET(url As String, useProxy As Boolean) As String
    Dim http As Object
    
    'create http object
    Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
    
    'proxy HTTP - [url]http://forums.aspfree.com/visual-basic-programming-38/proxy-auth-in-this-vb-script-20625.html[/url]
    If useProxy Then

        ' Set to use proxy - [url]http://msdn.microsoft.com/en-us/library/aa384059%28v=VS.85%29.aspx[/url]
        Const HTTPREQUEST_SETCREDENTIALS_FOR_PROXY = 1
        Const HTTPREQUEST_PROXYSETTING_PROXY = 2
        Const AutoLogonPolicy_Always = 0
        
        http.SetProxy HTTPREQUEST_PROXYSETTING_PROXY, [ProxyIP], "*.intra"
        http.Open "GET", url, False
        http.SetAutoLogonPolicy AutoLogonPolicy_Always
    
    Else
        http.Open "GET", url
    End If
       
    'send the request
    http.send
        
    'get response data as a string
    windowsHTTPGET = http.responseText

End Function

'perform the REST request on mac
Private Function macHTTPGET(url As String, useProxy As Boolean) As String
    Dim script As String
    
    
    'build the shell script, starts with `curl '<url>' --silent`
    If useProxy Then
        script = "do shell script " & Chr(34) & "curl '" & url & "'" & " --silent --proxy " & Range("proxyIP") & Chr(34)
    Else
        script = "do shell script " & Chr(34) & "curl '" & url & "'" & " --silent" & Chr(34)
    End If
    
    'run the shell script
    macHTTPGET = MacScript(script)
    
End Function


'URL encode a string
'From [url]http://stackoverflow.com/questions/218181/how-can-i-url-encode-a-string-in-excel-vba[/url]
Private Function URLEncode( _
   StringVal As String, _
   Optional SpaceAsPlus As Boolean = False _
) As String

On Error GoTo Catch

  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
Finally:
Exit Function
Catch:
URLEncode = ""
Resume Finally

End Function

'Check if Excel is running in Windows or Mac
'From [url]http://www.rondebruin.nl/mac.htm[/url]
Private Function isWindows() As Boolean

    'Test the OperatingSystem
    If Not Application.OperatingSystem Like "*Mac*" Then
        isWindows = True
    Else
        'Mac, but test if it is Excel 2011 or higher
        If Val(Application.Version) > 14 Then
            isWindows = False
        End If
    End If

End Function

'Get the element value in an XML document
'if excel for mac had regex support, we'd use that. it does not, so use these string functions to find lat/long/precision while maintaining win/mac compatibility
Private Function getElementValue(elementName As String)
    Dim element As String
    Dim startPosition As Long
    Dim endPosition As Long
    Dim elementLength As Long

    
    'find the start position of the start tag <ElementName> and add the length of the element to the position
    element = "<" & elementName & ">"
    startPosition = InStr(xml, element) + Len(element)
    
    'find the start position of the closing tag </ElementName>
    element = "</" & elementName & ">"
    endPosition = InStr(xml, element)
    
    'calculate the length of the element value
    elementLength = endPosition - startPosition
    
    'return the sub-string
    getElementValue = Mid(xml, startPosition, elementLength)
    
End Function
 
Last edited by a moderator:

June7

AWF VIP
Local time
Today, 05:58
Joined
Mar 9, 2014
Messages
5,423
Not really. Not going to try rebuilding workbook. No idea what might be on sheets that are needed by code.

For future, please post code between CODE tags to retain indentation and readability.
 

isladogs

MVP / VIP
Local time
Today, 13:58
Joined
Jan 14, 2017
Messages
18,186
The original file worked for me on a 10" tablet.
You will need to investigate the relevant Google API used to obtain the address on the linked webpage or use code to capture that element of the page.

Two things to bear in mind
1. In some countries such as the UK, you have a pay a fee to get a list of addresses from locations or postcodes. I use a provider to do this based on the postcode or partial address with each search being chargeable.
2. Partly related to the above, due to licensing issues, the addresses given by Google will be close but not always exact

You may find my free utility helpful to look at Get current geolocation
 

Rakesh935

Registered User.
Local time
Today, 19:28
Joined
Oct 14, 2012
Messages
71
The original file worked for me on a 10" tablet.
You will need to investigate the relevant Google API used to obtain the address on the linked webpage or use code to capture that element of the page.

Two things to bear in mind
1. In some countries such as the UK, you have a pay a fee to get a list of addresses from locations or postcodes. I use a provider to do this based on the postcode or partial address with each search being chargeable.
2. Partly related to the above, due to licensing issues, the addresses given by Google will be close but not always exact

You may find my free utility helpful to look at Get current geolocation

This application uses Bing Maps to generate the GeoCodes for the addresses ingested into it.

And Bing Maps offers 10,000 free searches per day.

Your true for the statement "due to licensing issues, the addresses given by Google will be close but not always exact",
and for the same reason requirement got changed and now in addition to the geocodes the team also needs the location address of the identified geocodes
in order to do further analysis between the ingested address Vs the the GeoCode's location address (to be) populated by the tool.

Hope I'm clear...
 

isladogs

MVP / VIP
Local time
Today, 13:58
Joined
Jan 14, 2017
Messages
18,186
I understood what you want from your first post.

I've not used Bing maps but the principles are very similar to using Google.
However, I'm unable to provide more specific info.
Did you look at the example app I mentioned in case it helps?

BTW why does your code refer to Google maps if you're using Bing?
 

Users who are viewing this thread

Top Bottom