├── README.md ├── classes └── cBingMapsRESTRequest.cls ├── excel-geocoding-tool.xls └── modules └── mGeoCode.bas /README.md: -------------------------------------------------------------------------------- 1 | # Excel Geocoding Tool 2 | Easy to use Geocoding Tool for Excel. Download, enable macros, and add your own location data. Click Geocode All and you're done. 3 | 4 | ## Requirements 5 | * Windows XP/Vista/7 (32bit/64bit) OR Mac OS X 10.5.8 or later (Intel) 6 | * Excel 2003/2007/2010 OR Excel 2011 for Mac 7 | 8 | ## Installation 9 | Simply [download](https://github.com/maxrice/excel-geocoding-tool/releases/download/3.6.1/excel-geocoding-tool.xls) and run the Excel file. Make sure to enable macros and enter a proxy address if necessary. 10 | 11 | ## Getting Started 12 | See the excel file for basic instructions. 13 | 14 | ## Donate 15 | Love the tool? Send a [donation](https://www.paypal.com/cgi-bin/webscr?cmd=_xclick&business=max@maxrice.com&item_name=Donation+for+Excel+Geocoding+Tool)! 16 | 17 | --------------- 18 | 19 | ### Changelog 20 | 21 | ### 3.6.1 - 2014-04-27 22 | * Tweak - You can now geocode up to 65k rows instead of 32k, huzzah! 23 | * Fix - Fix typo affecting "Geocode not found rows" functionality 24 | 25 | ### 3.6 - 2013-09-15 26 | * Feature - Mac compatibility returns! Use Excel for Mac 2011 or greater 27 | * Tweak - Refactor for easier maintainability 28 | * Tweak - Greatly improved error handling 29 | 30 | ### 3.5.1 - 2013-05-02 31 | * Fix - Fixed issue with error handling 32 | 33 | ### 3.5 - 2013-04-21 34 | * Fix - Use Bing for geocoding now that Yahoo's PlaceFinder API was discontinued 35 | 36 | ### 3.4.2 - 2012-07-15 37 | * Feature - Added debug mode 38 | * Tweak - Removed string cache, as it was causing a fatal error in some Excel versions 39 | * Tweak - Refactored some code in preparation for v3.5 release 40 | * Fix - fixed url encoding bug that affected accuracy of locations 41 | 42 | ### 3.4.1 - 2012-05-17 43 | * Feature - Proxy support on Mac 44 | * Tweak - Code readability and variable declaration 45 | * Fix - fixed curl url encoding bug on mac 46 | * Misc - Added MIT License notice 47 | 48 | ### 3.4 - 2012-05-12 49 | * Feature - Now works on Mac! (proxy support on mac coming in next version) 50 | * Tweak - Simpler proxy setup 51 | * Tweak - New instructions 52 | * Fix - Removed Create KML functionality 53 | 54 | ### 3.3 - 2012-03-28 55 | * Feature - Added macro to clear all data entry fields 56 | * Feature - Added Geocode Not Found macro to only retry not found locations 57 | * Feature - Added Google Maps link generation 58 | * Feature - Added Proxy traversal 59 | * Feature - Ability to geocode place names (ex: "The White House") or ZIP codes via free-form location format 60 | * Feature - Ability to geocode international locations 61 | * Tweak - Modified Geocode Selected Row macro to clear lat data, enabling it to run again 62 | * Tweak - Modified Geocode All macro to clear entered data 63 | * Tweak - Removed Google Earth auto-start on export 64 | 65 | ### 3.2 - 2012-03-27 66 | * Tweak - Removed juice analytics logo and misc. extraneous code 67 | * Tweak - Removed beep on geocode 68 | * Tweak - Removed geocoder.us 69 | * Fix - Changed Yahoo API to Placefinder API 70 | * Fix - Removed mClipboard module to make compatible with 64bit systems 71 | * Fork - Initial fork (http://www.juiceanalytics.com/writing/excel-geocoding-tool-v2/) 72 | 73 | ---------- 74 | 75 | ## Want to contribute? 76 | 77 | 1) Fork this repository 78 | 2) Make your changes to the worksheets / modules 79 | 3) Export any modules changed / added 80 | 4) Commit and send a pull request 81 | 82 | __Contributors: maxrice,juiceinc,switchman2210__ -------------------------------------------------------------------------------- /classes/cBingMapsRESTRequest.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "cBingMapsRESTRequest" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | 'MIT License 11 | 'Copyright 2012-2013 Max Rice (max@maxrice.com) 12 | 'Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files 13 | '(the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, 14 | 'merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished 15 | 'to do so, subject to the following conditions: 16 | ' 17 | 'The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 18 | ' 19 | 'THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 20 | 'MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE 21 | 'FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 22 | 'WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 23 | ' 24 | 'Enjoy! 25 | 26 | Option Explicit 27 | 28 | 'the URL to perform the request to 29 | Public url As String 30 | 31 | 'the response xml 32 | Public xml As String 33 | 34 | 'performs a REST lookup to Bing location service and parses the XML 35 | Public Function performLookup(location As String) 36 | Dim data(2) As String 37 | 38 | url = ("http://dev.virtualearth.net/REST/v1/Locations?query=" & URLEncode(location, True) & "&maxResults=1&key=" & Trim(CStr(Range("bingMapsKey"))) & "&o=xml") 39 | 40 | 'perform an HTTP GET 41 | xml = HTTPGET(url) 42 | 43 | '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 44 | If (InStr(xml, "") <> 0 And InStr(xml, "") <> 0 And InStr(xml, "") <> 0) Then 45 | data(0) = getElementValue("Latitude") 46 | data(1) = getElementValue("Longitude") 47 | data(2) = getElementValue("Confidence") 48 | Else 49 | data(0) = "-" 50 | data(1) = "-" 51 | data(2) = "-" 52 | End If 53 | 54 | performLookup = Join(data, "|") 55 | 56 | End Function 57 | 58 | 'return the request URI 59 | Public Function getRequestURI() 60 | getRequestURI = url 61 | End Function 62 | 63 | 'return the response XML 64 | Public Function getResponseXML() 65 | getResponseXML = xml 66 | End Function 67 | 68 | 'wrapper for the REST request to check proxy/OS 69 | Public Function HTTPGET(url As String) As String 70 | Dim useProxy As Boolean 71 | 72 | If Range("UseProxy") = "Yes" Then 73 | useProxy = True 74 | Else 75 | useProxy = False 76 | End If 77 | 78 | If (isWindows()) Then 79 | HTTPGET = windowsHTTPGET(url, useProxy) 80 | Else 81 | HTTPGET = macHTTPGET(url, useProxy) 82 | 83 | End If 84 | 85 | End Function 86 | 87 | 'perform the REST request on windows 88 | Private Function windowsHTTPGET(url As String, useProxy As Boolean) As String 89 | Dim http As Object 90 | 91 | 'create http object 92 | Set http = CreateObject("WinHttp.WinHttpRequest.5.1") 93 | 94 | 'proxy HTTP - http://forums.aspfree.com/visual-basic-programming-38/proxy-auth-in-this-vb-script-20625.html 95 | If useProxy Then 96 | 97 | ' Set to use proxy - http://msdn.microsoft.com/en-us/library/aa384059%28v=VS.85%29.aspx 98 | Const HTTPREQUEST_SETCREDENTIALS_FOR_PROXY = 1 99 | Const HTTPREQUEST_PROXYSETTING_PROXY = 2 100 | Const AutoLogonPolicy_Always = 0 101 | 102 | http.SetProxy HTTPREQUEST_PROXYSETTING_PROXY, [ProxyIP], "*.intra" 103 | http.Open "GET", url, False 104 | http.SetAutoLogonPolicy AutoLogonPolicy_Always 105 | 106 | Else 107 | http.Open "GET", url 108 | End If 109 | 110 | 'send the request 111 | http.send 112 | 113 | 'get response data as a string 114 | windowsHTTPGET = http.responseText 115 | 116 | End Function 117 | 118 | 'perform the REST request on mac 119 | Private Function macHTTPGET(url As String, useProxy As Boolean) As String 120 | Dim script As String 121 | 122 | 123 | 'build the shell script, starts with `curl '' --silent` 124 | If useProxy Then 125 | script = "do shell script " & Chr(34) & "curl '" & url & "'" & " --silent --proxy " & Range("proxyIP") & Chr(34) 126 | Else 127 | script = "do shell script " & Chr(34) & "curl '" & url & "'" & " --silent" & Chr(34) 128 | End If 129 | 130 | 'run the shell script 131 | macHTTPGET = MacScript(script) 132 | 133 | End Function 134 | 135 | 136 | 'URL encode a string 137 | 'From http://stackoverflow.com/questions/218181/how-can-i-url-encode-a-string-in-excel-vba 138 | Private Function URLEncode( _ 139 | StringVal As String, _ 140 | Optional SpaceAsPlus As Boolean = False _ 141 | ) As String 142 | 143 | On Error GoTo Catch 144 | 145 | Dim StringLen As Long: StringLen = Len(StringVal) 146 | 147 | If StringLen > 0 Then 148 | ReDim result(StringLen) As String 149 | Dim i As Long, CharCode As Integer 150 | Dim Char As String, Space As String 151 | 152 | If SpaceAsPlus Then Space = "+" Else Space = "%20" 153 | 154 | For i = 1 To StringLen 155 | Char = Mid(StringVal, i, 1) 156 | CharCode = Asc(Char) 157 | Select Case CharCode 158 | Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126 159 | result(i) = Char 160 | Case 32 161 | result(i) = Space 162 | Case 0 To 15 163 | result(i) = "%0" & Hex(CharCode) 164 | Case Else 165 | result(i) = "%" & Hex(CharCode) 166 | End Select 167 | Next i 168 | URLEncode = Join(result, "") 169 | End If 170 | Finally: 171 | Exit Function 172 | Catch: 173 | URLEncode = "" 174 | Resume Finally 175 | 176 | End Function 177 | 178 | 'Check if Excel is running in Windows or Mac 179 | 'From http://www.rondebruin.nl/mac.htm 180 | Private Function isWindows() As Boolean 181 | 182 | 'Test the OperatingSystem 183 | If Not Application.OperatingSystem Like "*Mac*" Then 184 | isWindows = True 185 | Else 186 | 'Mac, but test if it is Excel 2011 or higher 187 | If Val(Application.Version) > 14 Then 188 | isWindows = False 189 | End If 190 | End If 191 | 192 | End Function 193 | 194 | 'Get the element value in an XML document 195 | '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 196 | Private Function getElementValue(elementName As String) 197 | Dim element As String 198 | Dim startPosition As Long 199 | Dim endPosition As Long 200 | Dim elementLength As Long 201 | 202 | 203 | 'find the start position of the start tag and add the length of the element to the position 204 | element = "<" & elementName & ">" 205 | startPosition = InStr(xml, element) + Len(element) 206 | 207 | 'find the start position of the closing tag 208 | element = "" 209 | endPosition = InStr(xml, element) 210 | 211 | 'calculate the length of the element value 212 | elementLength = endPosition - startPosition 213 | 214 | 'return the sub-string 215 | getElementValue = Mid(xml, startPosition, elementLength) 216 | 217 | End Function 218 | 219 | 220 | -------------------------------------------------------------------------------- /excel-geocoding-tool.xls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/maxrice/excel-geocoding-tool/2ae65c45ae18f7e39b47c05dfcc0471e3a2fcda5/excel-geocoding-tool.xls -------------------------------------------------------------------------------- /modules/mGeoCode.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "mGeoCode" 2 | 'MIT License 3 | 'Copyright 2012-2013 Max Rice (max@maxrice.com), Juice Analytics 4 | 'Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files 5 | '(the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, 6 | 'merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished 7 | 'to do so, subject to the following conditions: 8 | ' 9 | 'The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 10 | ' 11 | 'THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 12 | 'MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE 13 | 'FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 14 | 'WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 15 | ' 16 | 'Enjoy! 17 | 18 | Option Explicit 19 | 20 | Const LATITUDECOL = 1 'column to put longitude into 21 | Const LONGITUDECOL = 2 'column to put latitude into 22 | Const CONFIDENCECOL = 3 'column to put confidence indicator into 23 | Const LOCATIONCOL = 4 'column to put location info into 24 | Const FIRSTDATAROW = 13 'rows above this row don't contain address data 25 | Const GOOGLEMAPSLINKCOL = 7 'column to store google maps link 26 | Const DEBUGMODEREQUESTCOL = 10 'column to store request URI if debug mode is on 27 | Const DEBUGMODERESPONSECOL = 11 'column to store response JSON if debug mode is on 28 | 29 | 'Global request/response variables for debugging 30 | Dim debugMode As Boolean 31 | Dim debugModeRequest As String 32 | Dim debugModeResponse As String 33 | 34 | 35 | 'geocode only selected rows 36 | Sub geocodeSelectedRows() 37 | 38 | If checkSettings = True Then 39 | 40 | Dim r 41 | For Each r In Selection.rows() 42 | If r.Row() >= FIRSTDATAROW Then 43 | geocodeRow (r.Row()) 44 | End If 45 | Next r 46 | 47 | Application.StatusBar = False 48 | 49 | End If 50 | 51 | End Sub 52 | 53 | 'geocode rows listed as "not found" 54 | Sub geocodeNotFound() 55 | 56 | If checkSettings = True Then 57 | 58 | 'Loop through result range and remove "not found" cells 59 | '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 :) 60 | Dim Row As Long, Column As Long 61 | For Row = FIRSTDATAROW To 65536 62 | For Column = LATITUDECOL To CONFIDENCECOL 63 | If Cells(Row, Column).Value = "not found" Then 64 | Cells(Row, Column).Value = "" 65 | End If 66 | Next Column 67 | Next Row 68 | 69 | Cells(FIRSTDATAROW, LATITUDECOL).Select 70 | 71 | 'Now geocode 72 | Dim r As Long 73 | For r = FIRSTDATAROW To LastDataRow() 74 | geocodeRow (r) 75 | Next r 76 | 77 | Cells(FIRSTDATAROW, LATITUDECOL).Select 78 | Application.StatusBar = False 79 | 80 | End If 81 | 82 | End Sub 83 | 84 | 'geocode ALL THE ROWS! 85 | Sub geocodeAllRows() 86 | 87 | If checkSettings = True Then 88 | 89 | Dim r As Long 90 | Range("A13:C65536").Select 91 | Selection.ClearContents 92 | Range("J13:j65536").Select 93 | Selection.ClearContents 94 | Cells(FIRSTDATAROW, LATITUDECOL).Select 95 | 96 | For r = FIRSTDATAROW To LastDataRow() 97 | geocodeRow (r) 98 | Next r 99 | 100 | Application.StatusBar = False 101 | 102 | End If 103 | 104 | End Sub 105 | 106 | 'geocode a single row of data 107 | Sub geocodeRow(r As Long) 108 | Dim rawGeocodeData As String 109 | Dim geocodeData 110 | Dim latitude As String 111 | Dim longitude As String 112 | Dim confidence As String 113 | 114 | Application.StatusBar = "Geocoding row: " & r 115 | 116 | 'can't geocode if no address data 117 | 'nonblank latitude means we've already geocoded this row 118 | If Cells(r, LOCATIONCOL) <> "" And Cells(r, LATITUDECOL) = "" Then 119 | 120 | ' pass the location to geocode 121 | ' bingAddressLookup returns an array containing the lat/long/confidence 122 | rawGeocodeData = bingAddressLookup(CStr(Cells(r, LOCATIONCOL))) 123 | 124 | geocodeData = Split(rawGeocodeData, "|") 125 | 126 | 'set lat/long/confidence 127 | latitude = geocodeData(0) 128 | longitude = geocodeData(1) 129 | confidence = geocodeData(2) 130 | 131 | 'if lat/long/confidence is blank, consider it not found 132 | If latitude = "-" Then latitude = "not found" 133 | If longitude = "-" Then longitude = "not found" 134 | If confidence = "-" Then confidence = "not found" 135 | 136 | ' store the results 137 | Cells(r, LATITUDECOL) = latitude 138 | Cells(r, LONGITUDECOL) = longitude 139 | Cells(r, CONFIDENCECOL) = confidence 140 | 141 | 'add google maps link 142 | If Cells(r, LATITUDECOL) <> "not found" Then 143 | Cells(r, GOOGLEMAPSLINKCOL).Value = "=HYPERLINK(""http://maps.google.com/maps?f=q&hl=en&geocode=&q=" & latitude & "," & longitude & """)" 144 | End If 145 | 146 | 'add logs if enabled 147 | If debugMode = True Then 148 | Cells(r, DEBUGMODEREQUESTCOL).Value = debugModeRequest 149 | Cells(r, DEBUGMODERESPONSECOL).Value = debugModeResponse 150 | Cells(r, DEBUGMODERESPONSECOL).WrapText = False 151 | End If 152 | 153 | End If 154 | 155 | End Sub 156 | 157 | 'Perform REST lookup on Bing 158 | Function bingAddressLookup(location As String) As String 159 | On Error Resume Next 160 | Dim bing As New cBingMapsRESTRequest 161 | Dim geocodeData As String 162 | 163 | Application.StatusBar = "Looking for " & location 164 | 165 | 'perform the lookup 166 | geocodeData = bing.performLookup(location) 167 | 168 | 'log response/request 169 | If (debugMode) Then 170 | debugModeRequest = bing.getRequestURI 171 | debugModeResponse = bing.getResponseXML 172 | End If 173 | 174 | 'return the lat/long/confidence 175 | bingAddressLookup = geocodeData 176 | 177 | End Function 178 | 179 | 'check that all settings are valid 180 | Function checkSettings() 181 | 182 | 'Check if Bing is selected as geocoder and API key is not blank 183 | If Range("GeocoderToUse") = "Bing" Then 184 | If Range("bingMapsKey") <> "" Then 185 | 186 | 'Set debug mode flag if setting is enabled 187 | If Range("DebugMode") = "On" Then 188 | debugMode = True 189 | Else 190 | debugMode = False 191 | End If 192 | 193 | 'Ready to Geocode 194 | checkSettings = True 195 | 196 | Else 197 | MsgBox "Please enter a Bing Maps Key for geocoding" 198 | 'Not ready to geocode 199 | checkSettings = False 200 | End If 201 | 202 | End If 203 | 204 | End Function 205 | 206 | Sub ClearDataEntryArea() 207 | Range("A13:K65536").Select 208 | Selection.ClearContents 209 | Range("A13").Select 210 | End Sub 211 | 212 | Private Function max(a, B): 213 | If a > B Then 214 | max = a 215 | Else 216 | max = B 217 | End If 218 | End Function 219 | 220 | ' locate the last row containing address data 221 | Function LastDataRow() As Integer 222 | Dim r As Long 223 | Dim activecelladdr As String 224 | 225 | activecelladdr = ActiveCell.Address 226 | 227 | Range("d65536").End(xlUp).Select 228 | r = ActiveCell.Row() 229 | Range("e65536").End(xlUp).Select 230 | r = max(r, ActiveCell.Row()) 231 | Range("f65536").End(xlUp).Select 232 | r = max(r, ActiveCell.Row()) 233 | Range("g65536").End(xlUp).Select 234 | r = max(r, ActiveCell.Row()) 235 | 236 | Range(activecelladdr).Select 237 | LastDataRow = r 238 | End Function 239 | 240 | 'Ensure that macros are working properly 241 | Sub MacrosWorking() 242 | MsgBox "Macros are enabled." 243 | End Sub 244 | 245 | --------------------------------------------------------------------------------