By: Lutfor Rahman Shimanto

In reply to Peter Berger.

Dear Peter Berger

Thanks for your feedback. Perhaps you are right about using the direct results from Nominatim, which would lead to more accurate outcomes. However, we have to get the result from the response from the Nominatim API.

In addition to your previous post, you wanted to get all the information in a column but in different cells. Do not worry! I have improved the previously given code by using a 2D array.

SOLUTION Overview:

Required Excel VBA User-Defined Functions:

Option Explicit

Function ReverseGeocoder(lati As Double, longi As Double) As Variant
On Error GoTo 0

Dim xD As New MSXML2.DOMDocument
Dim URL As String, vbErr As String

xD.async = False
URL = "https://nominatim.openstreetmap.org/reverse?lat=" + CStr(lati) + _
"&lon=" + CStr(longi)

xD.Load ("https://nominatim.openstreetmap.org/reverse?lat=" + CStr(lati) + _
"&lon=" + CStr(longi))

If xD.parseError.ErrorCode <> 0 Then
Application.Caller.Font.ColorIndex = vbErr
ReverseGeocoder = xD.parseError.reason
Else
xD.SetProperty "SelectionLanguage", "XPath"
Dim loca As MSXML2.IXMLDOMElement
Set loca = xD.SelectSingleNode("/reversegeocode/result")

If loca Is Nothing Then
Application.Caller.Font.ColorIndex = vbErr
ReverseGeocoder = xD.XML
Else
Application.Caller.Font.ColorIndex = vbOK
ReverseGeocoder = SplitStringToArray(loca.Text)
End If
End If

Exit Function

0:
Debug.Print Err.Description

End Function

Function SplitStringToArray(strInput As String) As Variant

Dim arrResult As Variant
Dim i As Integer

arrResult = Split(strInput, ", ")

Dim numRows As Long
numRows = UBound(arrResult) - LBound(arrResult) + 1

Dim result() As Variant
ReDim result(1 To numRows, 1 To 1)

For i = LBound(arrResult) To UBound(arrResult)
result(i + 1, 1) = arrResult(i)
Next i

SplitStringToArray = result

End Function

Hopefully, you have found the idea helpful. Download the solution workbook. Stay blessed.

DOWNLOAD SOLUTION WORKBOOK

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy