Ok, so some initial work see (BigTest() and EvenBiggerTest()) see remains from prior edit but after re-reading your comments I can see you wanted TextSearch. See please run TestTestSearch()
I have made it multipage aware in that Google returns 20 rows at a time plus a next page token if there is some more; so one supply the next page token to get the next page. This is not working reliably and I do not know why, for London restaurants never more than 60.
Feel free to step through the code, I have made plenty of interim variable which you can observe in the Locals Window to see the JSON structure.
There is some nice VBA.CallbyName logic which few people know about regarding interrogating a JSON structure (I found it on Korean website). Itching to post it on Stackoverflow.
You'll need to add the following project references, they import libraries
'Tools->References-> 'Microsoft Scripting Runtime 'Microsoft Script Control 1.0; {0E59F1D2-1FBE-11D0-8FF2-00A0D10038BC}; C:\Windows\SysWOW64\msscript.ocx 'Microsoft Xml, v6.0 Option Explicit Option Private Module Public Const sKEYNAME As String = "Server key 1" 'Public Const sKEY As String = "Your key goes here and uncomment" Public Const sSEVENOAKS_PLACEID As String = "ChIJwd9bXUyt2EcRYv6GY0JRnCw" 'Place ID: ChIJwd9bXUyt2EcRYv6GY0JRnCw Sevenoaks , Sevenoaks, Kent, UK Public Const sSEVENOAKS_LATITUDE_LONGITUDE As String = "51.2724,0.1909" '51.2724° N, 0.1909° E Private Sub BigTest() Dim dicPlacesWithPlaceIds As Scripting.Dictionary Set dicPlacesWithPlaceIds = AutoComplete(sKey, "Sevenoaks") ReDim v(1 To dicPlacesWithPlaceIds.Count + 1, 1 To 2) v(1, 1) = "Place": v(1, 2) = "Lat, Long" Dim lLoop As Long For lLoop = 1 To dicPlacesWithPlaceIds.Count Dim sPlace As String sPlace = dicPlacesWithPlaceIds.Keys()(lLoop - 1) Dim sPlaceID As String sPlaceID = dicPlacesWithPlaceIds.Items()(lLoop - 1) Dim dicPlaceDetails As Scripting.Dictionary Set dicPlaceDetails = PlaceDetails(sKey, sPlaceID) v(lLoop + 1, 1) = sPlace v(lLoop + 1, 2) = dicPlaceDetails.Items()(0) Next 'Stop ActiveSheet.Cells(1, 1).CurrentRegion.Clear ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(dicPlacesWithPlaceIds.Count + 1, 2)).Value2 = v End Sub Private Sub EvenBiggerTest() Dim dicPlacesWithPlaceIds As Scripting.Dictionary Set dicPlacesWithPlaceIds = AutoComplete(sKey, "Hamburg") If dicPlacesWithPlaceIds.Count > 0 Then Dim sTopPrediction As String sTopPrediction = dicPlacesWithPlaceIds.Keys()(0) Dim sTopPredictionPlaceId As String sTopPredictionPlaceId = dicPlacesWithPlaceIds.Items()(0) Dim dicPlaceDetails As Scripting.Dictionary Set dicPlaceDetails = PlaceDetails(sKey, sTopPredictionPlaceId) Dim sTopPredictionLocation As String sTopPredictionLocation = dicPlaceDetails.Item("Location") Dim dicNearbySearchResults As Scripting.Dictionary Set dicNearbySearchResults = NearbySearch(sKey, sTopPredictionLocation, 100, "post office") ReDim v(1 To dicNearbySearchResults.Count + 1, 1 To 5) v(1, 1) = "Name": v(1, 2) = "PlaceId": v(1, 3) = "Address": v(1, 4) = "Vicinity": v(1, 5) = "Type0" 'dicPlaceDetails.Add "Location", sLatitude & "," & sLongitude 'dicPlaceDetails.Add "Address", VBA.CallByName(objResult, "formatted_address", VbGet) 'dicPlaceDetails.Add "Name", VBA.CallByName(objResult, "name", VbGet) 'dicPlaceDetails.Add "Vicinity", VBA.CallByName(objResult, "vicinity", VbGet) 'dicPlaceDetails.Add "PlaceId", sPlaceID Dim lLoop As Long For lLoop = 1 To dicNearbySearchResults.Count Dim sPlaceIdLoop As String sPlaceIdLoop = dicNearbySearchResults.Items()(lLoop - 1) Set dicPlaceDetails = PlaceDetails(sKey, sPlaceIdLoop) v(lLoop + 1, 1) = dicNearbySearchResults.Keys()(lLoop - 1) v(lLoop + 1, 2) = sPlaceIdLoop v(lLoop + 1, 3) = dicPlaceDetails.Item("Address") If dicPlaceDetails.Exists("Vicinity") Then v(lLoop + 1, 4) = dicPlaceDetails.Item("Vicinity") End If If dicPlaceDetails.Exists("Type0") Then v(lLoop + 1, 5) = dicPlaceDetails.Item("Type0") End If 'dicNearbySearchResults.Items()(lLoop - 1) Next 'Stop ActiveSheet.Cells(1, 1).CurrentRegion.Clear ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(dicNearbySearchResults.Count + 1, 5)).Value2 = v End If End Sub Private Sub TestAutoComplete() Dim dicPlacesWithPlaceIds As Scripting.Dictionary Set dicPlacesWithPlaceIds = AutoComplete(sKey, "Sevenoaks") Debug.Assert dicPlacesWithPlaceIds.Keys()(0) = "Sevenoaks, United Kingdom" Debug.Assert dicPlacesWithPlaceIds.Items()(0) = sSEVENOAKS_PLACEID End Sub Private Sub TestNearbySearch() Dim dicNearbySearchResults As Scripting.Dictionary Set dicNearbySearchResults = NearbySearch(sKey, sSEVENOAKS_LATITUDE_LONGITUDE, 500, "restaurant") Debug.Assert dicNearbySearchResults.Exists("Subway") Debug.Assert dicNearbySearchResults.Item("Subway") = "ChIJ_yoN0_tN30cRnjjjqftbnSw" Stop End Sub Private Sub TestPlaceDetails() Dim dicPlaceDetails As Scripting.Dictionary Set dicPlaceDetails = PlaceDetails(sKey, sSEVENOAKS_PLACEID) Debug.Assert dicPlaceDetails.Keys()(0) = "Location" Debug.Assert dicPlaceDetails.Items()(0) = "51.27241,0.190898" End Sub Private Sub TestTextSearch() Dim pdicFieldOrinals As Scripting.Dictionary Dim dicTextSearchResults As Scripting.Dictionary Set dicTextSearchResults = TextSearch(sKey, "london+restaurants", pdicFieldOrinals) Dim dicDetails As Scripting.Dictionary Set dicDetails = dicTextSearchResults.Item(dicTextSearchResults.Keys()(0)) Dim vGrid As Variant vGrid = NestedDictionaryToGrid(dicTextSearchResults, pdicFieldOrinals) ActiveSheet.Cells(1, 1).CurrentRegion.Clear ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(dicTextSearchResults.Count + 1, pdicFieldOrinals.Count)).Value2 = vGrid 'd'ebug.Print dicDetails.Item("lat,lng") 'Debug.Print dicDetails.Item("types") 'Stop 'Debug.Assert dicTextSearchResults.Exists("Subway") 'Debug.Assert dicTextSearchResults.Item("Subway") = "ChIJ_yoN0_tN30cRnjjjqftbnSw" 'Stop End Sub Public Function CreateScriptControl() As ScriptControl Static oScriptEngine As ScriptControl If oScriptEngine Is Nothing Then Set oScriptEngine = New ScriptControl oScriptEngine.Language = "JScript" oScriptEngine.AddCode "function getKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; } " End If Set CreateScriptControl = oScriptEngine End Function Public Function TextSearch(ByVal sAPIKey As String, ByVal sSearchQuery As String, ByRef pdicFieldOrinals As Scripting.Dictionary) As Scripting.Dictionary ' 'Tools->References-> 'Microsoft Scripting Runtime Dim dicTextSearchResults As Scripting.Dictionary Set dicTextSearchResults = New Scripting.Dictionary Set pdicFieldOrinals = New Scripting.Dictionary Dim psNextPageToken As String: psNextPageToken = "" Dim oScriptEngine As ScriptControl Set oScriptEngine = CreateScriptControl Do Dim xHTTPRequest As MSXML2.XMLHTTP60 Set xHTTPRequest = New MSXML2.XMLHTTP60 Dim sURL As String sURL = "https://maps.googleapis.com/maps/api/place/textsearch/json?key=" & sAPIKey & "&query=" & sSearchQuery If psNextPageToken <> "" Then sURL = sURL & "&pagetoken=" & psNextPageToken xHTTPRequest.Open "GET", sURL xHTTPRequest.send While xHTTPRequest.readyState <> 4 DoEvents Wend If Len(xHTTPRequest.responseText) > 0 Then Debug.Print Left$(xHTTPRequest.responseText, 500) Dim objJSON As Object Set objJSON = oScriptEngine.Eval("(" + xHTTPRequest.responseText + ")") ParseTextSearchResponse oScriptEngine, objJSON, dicTextSearchResults, pdicFieldOrinals, psNextPageToken End If Loop Until psNextPageToken = "" Set TextSearch = dicTextSearchResults End Function Public Function ParseTextSearchResponse(ByVal oScriptEngine As ScriptControl, ByVal objJSON As Object, _ ByVal dicTextSearchResults As Scripting.Dictionary, ByVal dicFieldOrinals As Scripting.Dictionary, _ ByRef psPageToken As String) If Not objJSON Is Nothing Then Dim dicTopKeys As Scripting.Dictionary Set dicTopKeys = GetKeys(oScriptEngine, objJSON) If dicTopKeys.Exists("next_page_token") Then psPageToken = VBA.CallByName(objJSON, "next_page_token", VbGet) Else psPageToken = "" End If If dicTopKeys.Exists("status") Then Dim sStatus As String sStatus = VBA.CallByName(objJSON, "status", VbGet) If sStatus = "OK" Then Dim objResults As Object Set objResults = VBA.CallByName(objJSON, "results", VbGet) Dim lLength As Long lLength = VBA.CallByName(objResults, "length", VbGet) Dim lLoop As Long For lLoop = 0 To lLength - 1 Dim objResultLoop As Object Set objResultLoop = VBA.CallByName(objResults, CStr(lLoop), VbGet) Dim sName As String sName = VBA.CallByName(objResultLoop, "name", VbGet) Dim dicKeys As Scripting.Dictionary Set dicKeys = GetKeys(oScriptEngine, objResultLoop) Dim dicFlattenedDetails As Scripting.Dictionary Set dicFlattenedDetails = New Scripting.Dictionary Dim vKeyLoop As Variant For Each vKeyLoop In dicKeys.Keys If Not dicFieldOrinals.Exists(vKeyLoop) Then dicFieldOrinals.Add vKeyLoop, dicFieldOrinals.Count Dim vValue As Variant: vValue = Empty Select Case vKeyLoop Case "formatted_address", "icon", "id", "name", "permanently_closed", "place_id", "price_level", "rating", "reference": vValue = VBA.CallByName(objResultLoop, vKeyLoop, VbGet) dicFlattenedDetails.Add vKeyLoop, vValue Case "geometry": dicFlattenedDetails.Add "geometry", ExtractLatitudeAndLongitude(VBA.CallByName(objResultLoop, "geometry", VbGet)) Case "opening_hours": dicFlattenedDetails.Add "opening_hours", ExtractOpeningHours(oScriptEngine, VBA.CallByName(objResultLoop, "opening_hours", VbGet)) Case "types": dicFlattenedDetails.Add "types", ExtractTypes(VBA.CallByName(objResultLoop, "types", VbGet)) Case "photos": '* NOT YET IMPLEMENTED Case Else Stop End Select Next vKeyLoop Dim sPlaceID As String sPlaceID = VBA.CallByName(objResultLoop, "place_id", VbGet) Dim sVicinity As String 'sVicinity = VBA.CallByName(objResultLoop, "vicinity", VbGet) dicTextSearchResults.Add sPlaceID, dicFlattenedDetails Next End If End If End If End Function Public Function ExtractOpeningHours(ByVal oScriptEngine As ScriptControl, ByVal objOpeningHours As Object) As String Dim vOpenNow As Variant vOpenNow = VBA.CallByName(objOpeningHours, "open_now", VbGet) Dim bOpenNow As Boolean bOpenNow = CBool(vOpenNow) Dim objWeekdayText As Object Set objWeekdayText = VBA.CallByName(objOpeningHours, "weekday_text", VbGet) Dim lLength As Long lLength = VBA.CallByName(objWeekdayText, "length", VbGet) If lLength > 0 Then Dim dicWeekdaysKeys As Scripting.Dictionary Set dicWeekdaysKeys = GetKeys(oScriptEngine, objWeekdayText) End If ExtractOpeningHours = VBA.IIf(bOpenNow, "open", "closed") End Function Public Function ExtractTypes(ByVal objTypes As Object) As String Dim lLength As Long lLength = VBA.CallByName(objTypes, "length", VbGet) Dim dicTypes As Scripting.Dictionary Set dicTypes = New Scripting.Dictionary Dim lLoop As Long For lLoop = 0 To lLength - 1 Dim sTypeLoop As String sTypeLoop = VBA.CallByName(objTypes, CStr(lLoop), VbGet) dicTypes.Add sTypeLoop, 0 Next lLoop ExtractTypes = VBA.Join(dicTypes.Keys, "|") End Function Public Function GetKeys(ByVal oScriptEngine As ScriptControl, ByVal JsonObject As Object) As Scripting.Dictionary Dim dicReturn As Scripting.Dictionary Set dicReturn = New Scripting.Dictionary Dim objKeysObject As Object Set objKeysObject = oScriptEngine.Run("getKeys", JsonObject) Dim lLength As Long lLength = VBA.CallByName(objKeysObject, "length", VbGet) Dim lLoop As Long For lLoop = 0 To lLength - 1 Dim vKeyLoop As Variant vKeyLoop = VBA.CallByName(objKeysObject, CStr(lLoop), VbGet) Debug.Assert Not dicReturn.Exists(vKeyLoop) dicReturn.Add vKeyLoop, 0 Next lLoop Set GetKeys = dicReturn End Function Public Function NearbySearch(ByVal sAPIKey As String, ByVal sLocationLatitudeLongitude As String, ByVal lRadius As Long, _ ByVal sSearchType As String) ' 'Tools->References-> 'Microsoft Scripting Runtime Dim dicNearbySearchResults As Scripting.Dictionary Set dicNearbySearchResults = New Scripting.Dictionary Dim xHTTPRequest As MSXML2.XMLHTTP60 Set xHTTPRequest = New MSXML2.XMLHTTP60 xHTTPRequest.Open "GET", "https://maps.googleapis.com/maps/api/place/nearbysearch/json?key=" & sAPIKey & "&location=" & sLocationLatitudeLongitude & "&radius=" & lRadius & "&type=" & sSearchType xHTTPRequest.send While xHTTPRequest.readyState <> 4 DoEvents Wend If Len(xHTTPRequest.responseText) > 0 Then 'Debug.Print xHTTPRequest.responseText Dim oScriptEngine As ScriptControl Set oScriptEngine = New ScriptControl oScriptEngine.Language = "JScript" Dim objJSON As Object Set objJSON = oScriptEngine.Eval("(" + xHTTPRequest.responseText + ")") If Not objJSON Is Nothing Then If TypeName(CallByName(objJSON, "status", VbGet)) <> "Nothing" Then Dim sStatus As String sStatus = VBA.CallByName(objJSON, "status", VbGet) If sStatus = "OK" Then Dim objResults As Object Set objResults = VBA.CallByName(objJSON, "results", VbGet) Dim lLength As Long lLength = VBA.CallByName(objResults, "length", VbGet) Dim lLoop As Long For lLoop = 0 To lLength - 1 Dim objResultLoop As Object Set objResultLoop = VBA.CallByName(objResults, CStr(lLoop), VbGet) Dim sName As String sName = VBA.CallByName(objResultLoop, "name", VbGet) Dim sPlaceID As String sPlaceID = VBA.CallByName(objResultLoop, "place_id", VbGet) Dim sVicinity As String 'sVicinity = VBA.CallByName(objResultLoop, "vicinity", VbGet) dicNearbySearchResults.Add sName, sPlaceID Next End If End If End If End If Set NearbySearch = dicNearbySearchResults End Function Public Function ExtractLatitudeAndLongitude(ByVal objGeometry As Object) As String Dim objLocation As Object Set objLocation = VBA.CallByName(objGeometry, "location", VbGet) Dim sLatitude As String sLatitude = VBA.CallByName(objLocation, "lat", VbGet) Dim sLongitude As String sLongitude = VBA.CallByName(objLocation, "lng", VbGet) ExtractLatitudeAndLongitude = sLatitude & "," & sLongitude End Function Public Function PlaceDetails(ByVal sAPIKey As String, ByVal sPlaceID As String) As Scripting.Dictionary 'Tools->References-> 'Microsoft Scripting Runtime Dim dicPlaceDetails As Scripting.Dictionary Set dicPlaceDetails = New Scripting.Dictionary Dim xHTTPRequest As MSXML2.XMLHTTP60 Set xHTTPRequest = New MSXML2.XMLHTTP60 xHTTPRequest.Open "GET", "https://maps.googleapis.com/maps/api/place/details/json?key=" & sAPIKey & "&placeid=" & sPlaceID xHTTPRequest.send While xHTTPRequest.readyState <> 4 DoEvents Wend If Len(xHTTPRequest.responseText) > 0 Then Dim oScriptEngine As ScriptControl Set oScriptEngine = New ScriptControl oScriptEngine.Language = "JScript" Dim objJSON As Object Set objJSON = oScriptEngine.Eval("(" + xHTTPRequest.responseText + ")") If Not objJSON Is Nothing Then If TypeName(CallByName(objJSON, "result", VbGet)) <> "Nothing" Then Dim objResult As Object Set objResult = VBA.CallByName(objJSON, "result", VbGet) If TypeName(CallByName(objResult, "geometry", VbGet)) <> "Nothing" Then Dim objGeometry As Object Set objGeometry = VBA.CallByName(objResult, "geometry", VbGet) If TypeName(CallByName(objGeometry, "location", VbGet)) <> "Nothing" Then Dim objLocation As Object Set objLocation = VBA.CallByName(objGeometry, "location", VbGet) Dim sLatitude As String sLatitude = VBA.CallByName(objLocation, "lat", VbGet) Dim sLongitude As String sLongitude = VBA.CallByName(objLocation, "lng", VbGet) dicPlaceDetails.Add "Location", sLatitude & "," & sLongitude dicPlaceDetails.Add "Address", VBA.CallByName(objResult, "formatted_address", VbGet) dicPlaceDetails.Add "Name", VBA.CallByName(objResult, "name", VbGet) If JSONKeyExists(objResult, "vicinity", False) Then dicPlaceDetails.Add "Vicinity", VBA.CallByName(objResult, "vicinity", VbGet) End If If JSONKeyExists(objResult, "types", True) Then Dim objTypes As Object Set objTypes = VBA.CallByName(objResult, "types", VbGet) Dim lTypesLength As Long lTypesLength = VBA.CallByName(objTypes, "length", VbGet) Dim sType0 As String sType0 = VBA.CallByName(objTypes, "0", VbGet) dicPlaceDetails.Add "Type0", sType0 End If dicPlaceDetails.Add "PlaceId", sPlaceID End If End If End If End If End If Set PlaceDetails = dicPlaceDetails End Function Private Function JSONKeyExists(ByRef objJSON As Object, ByVal sKey As String, ByVal bIsObject As Boolean) On Error GoTo ErrHandler If bIsObject Then Dim obj As Object Set obj = VBA.CallByName(objJSON, sKey, VbGet) 'If error this jumps to error handler Else Dim vValue As Variant vValue = VBA.CallByName(objJSON, sKey, VbGet) 'If error this jumps to error handler End If JSONKeyExists = True Exit Function ErrHandler: End Function Public Function AutoComplete(ByVal sAPIKey As String, ByVal sPlaceText As String) As Scripting.Dictionary 'Tools->References-> 'Microsoft Scripting Runtime Dim dicPlacesWithPlaceIds As Scripting.Dictionary Set dicPlacesWithPlaceIds = New Scripting.Dictionary Dim xHTTPRequest As MSXML2.XMLHTTP60 Set xHTTPRequest = New MSXML2.XMLHTTP60 xHTTPRequest.Open "GET", "https://maps.googleapis.com/maps/api/place/autocomplete/json?key=" & sAPIKey & "&input=" & sPlaceText & "&sensor=false", False xHTTPRequest.send While xHTTPRequest.readyState <> 4 DoEvents Wend If Len(xHTTPRequest.responseText) > 0 Then Dim oScriptEngine As ScriptControl Set oScriptEngine = New ScriptControl oScriptEngine.Language = "JScript" Dim objJSON As Object Set objJSON = oScriptEngine.Eval("(" + xHTTPRequest.responseText + ")") If Not objJSON Is Nothing Then If TypeName(CallByName(objJSON, "predictions", VbGet)) <> "Nothing" Then Dim objPredictions As Object Set objPredictions = VBA.CallByName(objJSON, "predictions", VbGet) Dim lLength As Long 'lLength = ScriptEngine.Run("getProperty", objPredictions, "length") lLength = VBA.CallByName(objPredictions, "length", VbGet) Dim lLoop As Long For lLoop = 0 To lLength - 1 Dim objPredictionLoop As Object Set objPredictionLoop = VBA.CallByName(objPredictions, CStr(lLoop), VbGet) Dim sPlaceDescription As String sPlaceDescription = VBA.CallByName(objPredictionLoop, "description", VbGet) Dim sPlaceID As String sPlaceID = VBA.CallByName(objPredictionLoop, "place_id", VbGet) dicPlacesWithPlaceIds.Add sPlaceDescription, sPlaceID 'Stop Next 'Stop End If End If 'Stop End If Set AutoComplete = dicPlacesWithPlaceIds 'Debug.Print xHTTPRequest.responseText End Function Public Function NestedDictionaryToGrid(ByVal dicData As Scripting.Dictionary, ByVal dicFieldOrdinals As Scripting.Dictionary) As Variant ReDim vRet(1 To dicData.Count + 1, 1 To dicFieldOrdinals.Count) Dim vFieldKeyLoop As Variant For Each vFieldKeyLoop In dicFieldOrdinals.Keys vRet(1, dicFieldOrdinals.Item(vFieldKeyLoop) + 1) = vFieldKeyLoop Next Dim lRowLoop As Long: lRowLoop = 1 Dim vDataKeyLoop As Variant For Each vDataKeyLoop In dicData.Keys lRowLoop = lRowLoop + 1 Dim dicDetails As Scripting.Dictionary Set dicDetails = dicData.Item(vDataKeyLoop) For Each vFieldKeyLoop In dicFieldOrdinals.Keys vRet(lRowLoop, dicFieldOrdinals.Item(vFieldKeyLoop) + 1) = dicDetails.Item(vFieldKeyLoop) Next Next vDataKeyLoop NestedDictionaryToGrid = vRet End Function
