I used a tutorial to automatically calculate travel distance using Google Directions API, based on addresses I enter in Excel. I succesfully created an API key and I used a tutorial page that showed two functions in VBA, one for Time and one for Distance:
'Returns the number of seconds it would take to get from one place to another
Function TRAVELTIME(origin, destination, apikey)
Dim strUrl As String
strUrl = "https://maps.googleapis.com/maps/api/directions/json?origin=" & origin & "&destination=" & destination & "&key=" & apikey
Set httpReq = CreateObject("MSXML2.XMLHTTP")
With httpReq
.Open "GET", strUrl, False
.Send
End With
Dim response As String
response = httpReq.ResponseText
Dim parsed As Dictionary
Set parsed = JsonConverter.ParseJson(response)
Dim seconds As Integer
Dim leg As Dictionary
For Each leg In parsed("routes")(1)("legs")
seconds = seconds + leg("duration")("value")
Next leg
TRAVELTIME = seconds
End Function
' Returns the distance
Function TRAVELDISTANCE(origin, destination, apikey)
Dim strUrl As String
strUrl = "https://maps.googleapis.com/maps/api/directions/json?origin=" & origin & "&destination=" & destination & "&key=" & apikey
Set httpReq = CreateObject("MSXML2.XMLHTTP")
With httpReq
.Open "GET", strUrl, False
.Send
End With
Dim response As String
response = httpReq.ResponseText
Dim parsed As Dictionary
Set parsed = JsonConverter.ParseJson(response)
Dim meters As Integer
Dim leg As Dictionary
For Each leg In parsed("routes")(1)("legs")
meters = meters + leg("distance")("value")
Next leg
TRAVELDISTANCE = meters
End Function
When I try to use the distance function, it fails most of the time. I can get it to work if I enter a single dimension of a location, e.g. "Kerkstraat 10", but if I add the city name, e.g. "Kerkstraat 10, Amsterdam", I get a #Value error in Excel.
Whether I use spaces, commas, semicolons, %20 or whatever in VBA doesn't seem to matter and interestingly, the traveltime function works perfectly with a "full" address.
Does anyone know what might be wrong, or if there is a better/different way to get what I need?
Thanks in advance!
I had the same issue, and what I did was just replace integer with long for the meters and seconds variables and it worked.
Related
I'm getting
run-time error 424
in 68th row (line)
request.Open "GET", Url, False
and I don't know how to fix it.
My previous question I posted ;
How to scrape specific part of online english dictionary?
My final goal is to get result like this;
A B
beginning bɪˈɡɪnɪŋ
behalf bɪˈhæf
behave bɪˈheɪv
behaviour bɪˈheɪvjər
belong bɪˈlɔːŋ
below bɪˈloʊ
bird bɜːrd
biscuit ˈbɪskɪt
Here's code I wrote, and it's mostly based on someone else's code I found on internet.
' Microsoft ActiveX Data Objects x.x Library
' Microsoft XML, v3.0
' Microsoft VBScript Regular Expressions
Sub ParseHelp()
' Word reference from
Dim Url As String
Url = "https://www.oxfordlearnersdictionaries.com/definition/english/" & Cells(ActiveCell.Row, "B").Value
' Get dictionary's html
Dim Html As String
Html = GetHtml(Url)
' Check error
If InStr(Html, "<TITLE>Not Found</Title>") > 0 Then
MsgBox "404"
Exit Sub
End If
' Extract phonetic alphabet from HTML
Dim wrapPattern As String
wrapPattern = "<span class='name' (.*?)</span>"
Set wrapCollection = FindRegexpMatch(Html, wrapPattern)
' MsgBox StripHtml(CStr(wrapCollection(1)))
' Fill phonetic alphabet into cell
If Not wrapCollection Is Nothing Then
Dim wrap As String
On Error Resume Next
wrap = StripHtml(CStr(wrapCollection(1)))
If Err.Number <> 0 Then
wrap = ""
End If
Cells(ActiveCell.Row, "C").Value = wrap
Else
MsgBox "not found"
End If
End Sub
Public Function StripHtml(Html As String) As String
Dim RegEx As New RegExp
Dim sOut As String
Html = Replace(Html, "</li>", vbNewLine)
Html = Replace(Html, " ", " ")
With RegEx
.Global = True
.IgnoreCase = True
.MultiLine = True
.Pattern = "<[^>]+>"
End With
sOut = RegEx.Replace(Html, "")
StripHtml = sOut
Set RegEx = Nothing
End Function
Public Function GetHtml(Url As String) As String
Dim xmlhttp As Object
Set xmlhttp = CreateObject("MSXML2.serverXMLHTTP")
Dim converter As New ADODB.stream
' Get
request.Open "GET", Url, False
request.send
' raw bytes
converter.Open
converter.Type = adTypeBinary
converter.Write request.responseBody
' read
converter.Position = 0
converter.Type = adTypeText
converter.Charset = "utf-8"
' close
GetHtml = converter.ReadText
converter.Close
End Function
Public Function FindRegexpMatch(txt As String, pat As String) As Collection
Set FindRegexpMatch = New Collection
Dim rx As New RegExp
Dim matcol As MatchCollection
Dim mat As Match
Dim ret As String
Dim delimiter As String
txt = Replace(txt, Chr(10), "")
txt = Replace(txt, Chr(13), "")
rx.Global = True
rx.IgnoreCase = True
rx.MultiLine = True
rx.Pattern = pat
Set matcol = rx.Execute(txt)
'MsgBox "Match:" & matcol.Count
On Error GoTo ErrorHandler
For Each mat In matcol
'FindRegexpMatch.Add mat.SubMatches(0)
FindRegexpMatch.Add mat.Value
Next mat
Set rx = Nothing
' Insert code that might generate an error here
Exit Function
ErrorHandler:
' Insert code to handle the error here
MsgBox "FindRegexpMatch. " & Err.GetException()
Resume Next
End Function
Any kind of help would be greatly appreciated.
The following is an example of how to read in values from column A and write out pronounciations to column B. It uses css selectors to match a child node then steps up to parentNode in order to ensure entire pronounciation is grabbed. There are a number of ways you could have matched on the parent node to get the second pronounciation. Note that I use a parent node and Replace as the pronounciation may span multiple childNodes.
If doing this for lots of lookups please be a good netizen and put some waits in the code so as to not bombard the site with requests.
Option Explicit
Public Sub WriteOutPronounciations()
Dim html As MSHTML.HTMLDocument, i As Long, ws As Worksheet
Dim data As String, lastRow As Long, urls()
Set ws = ThisWorkbook.Worksheets("Sheet1")
lastRow = ws.Cells(ws.rows.Count, "A").End(xlUp).row 'you need at least two words in column A or change the redim.
urls = Application.Transpose(ws.Range("A1:A" & lastRow).Value)
ReDim results(1 To UBound(urls))
Set html = New MSHTML.HTMLDocument
With CreateObject("MSXML2.ServerXMLHTTP")
For i = LBound(urls) To UBound(urls)
.Open "GET", "https://www.oxfordlearnersdictionaries.com/definition/english/" & urls(i), False
.send
html.body.innerHTML = .responseText
data = Replace$(Replace$(html.querySelector(".name ~ .wrap").ParentNode.innerText, "/", vbNullString), Chr$(10), Chr$(32))
results(i) = Right$(data, Len(data) - 4)
Next
End With
With ThisWorkbook.Worksheets(1)
.Cells(1, 2).Resize(UBound(results, 1), 1) = Application.Transpose(results)
End With
End Sub
Required references (VBE>Tools>References):
Microsoft HTML Object Library
Should you go down the API route then here is a small example. You can make 1000 free calls in a month with Prototype account. The next best, depending on how many calls you wish to make looks like the 10,001 calls (that one extra PAYG call halves the price). # calls will be affected by whether word is head word or needs lemmas lookup call first. The endpoint construction you need is GET /entries/{source_lang}/{word_id}?fields=pronunciations though that doesn't seem to filter massively. You will need a json parser to handle the json returned e.g. github.com/VBA-tools/VBA-JSON/blob/master/JsonConverter.bas. Download raw code from there and add to standard module called JsonConverter. You then need to go VBE > Tools > References > Add reference to Microsoft Scripting Runtime. Remove the top Attribute line from the copied code.
Option Explicit
Public Sub WriteOutPronounciations()
Dim html As MSHTML.HTMLDocument, i As Long, ws As Worksheet
Dim data As String, lastRow As Long, words()
'If not performing lemmas lookup then must be head word e.g. behave, behalf
Const appId As String = "yourAppId"
Const appKey As String = "yourAppKey"
Set ws = ThisWorkbook.Worksheets("Sheet1")
lastRow = ws.Cells(ws.rows.Count, "A").End(xlUp).row
words = Application.Transpose(ws.Range("A1:A" & lastRow).Value)
ReDim results(1 To UBound(words))
Set html = New MSHTML.HTMLDocument
Dim json As Object
With CreateObject("MSXML2.ServerXMLHTTP")
For i = LBound(words) To UBound(words)
.Open "GET", "https://od-api.oxforddictionaries.com/api/v2/entries/en-us/" & LCase$(words(i)) & "?fields=pronunciations", False
.setRequestHeader "app_id", appId
.setRequestHeader "app_key", appKey
.setRequestHeader "ContentType", "application/json"
.send
Set json = JsonConverter.ParseJson(.responseText)
results(i) = IIf(json("results")(1)("type") = "headword", json("results")(1)("lexicalEntries")(1)("pronunciations")(2)("phoneticSpelling"), "lemmas lookup required")
Set json = Nothing
Next
End With
With ThisWorkbook.Worksheets(1)
.Cells(1, 2).Resize(UBound(results, 1), 1) = Application.Transpose(results)
End With
End Sub
I have developed a code to scrape data from a websites but since I know very little about JSON I could be able to get the output as I want, the code was developed for this web: https://ngodarpan.gov.in/index.php/home/statewise_ngo/76/35/1 now I am replicating my code for other websites having json like this web :https://www.yelp.com/search?cflt=hvac&find_loc=San+Francisco%2C+CA ; but this code is not functioning properly. Here is my code(I want it to be generic for most webs)
Option Explicit
Public Sub FetchTabularInfo()
Dim Http As XMLHTTP60, Html As HTMLDocument, col As Variant, csrf As Variant, i&, page As Long
Dim headers(), ws As Worksheet, iCol As Collection
Set ws = ThisWorkbook.Worksheets("Sheet1")
headers = Array("SrNo", "Name", "Address", "Mobile", "Email")
Set Http = New XMLHTTP60
Set Html = New HTMLDocument
ws.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
For page = 1 To 8 'To cover all pages
With Http
.Open "GET", "https://www.yelp.com/search?cflt=hvac&find_loc=San+Francisco%2C+CA" & CStr(page), Falsev 'Last letter of URL is page number whose range will be given in outerloop
.send
Html.body.innerHTML = .responseText
End With
Set iCol = New Collection
With Html.querySelectorAll(".table tr a[onclick^='show_ngo_info']")
For i = 0 To .Length - 1
iCol.Add Split(Split(.Item(i).getAttribute("onclick"), "(""")(1), """)")(0)
Next i
End With
Dim r As Long, results()
ReDim results(1 To iCol.Count, 1 To UBound(headers) + 1)
r = 0
For Each col In iCol
r = r + 1
With Http
.Open "GET", "https://www.yelp.com/index.php/ajaxcontroller/get_csrf", False
.send
csrf = .responseText
End With
csrf = Split(Replace(Split(csrf, ":")(1), """", ""), "}")(0)
Dim json As Object
With Http
.Open "POST", "https://www.yelp.com/index.php/ajaxcontroller/show_ngo_info", False
.setRequestHeader "X-Requested-With", "XMLHttpRequest"
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
.send "id=" & col & "&csrf_test_name=" & csrf
Set json = JsonConverter.ParseJson(.responseText)
Dim orgName As String, address As String, srNo As Long, city As String
Dim state As String, tel As String, mobile As String, website As String, email As String
On Error Resume Next
orgName = json("registeration_info")(1)("nr_orgName")
address = json("registeration_info")(1)("nr_add")
srNo = r '<unsure where this is coming from.
mobile = json("infor")("0")("Mobile")
email = json("infor")("0")("Email")
On Error GoTo 0
Dim arr()
arr = Array(srNo, orgName, address, tel, email)
For i = LBound(headers) To UBound(headers)
results(r, i + 1) = arr(i)
Next
End With
Next col
Set iCol = Nothing: Set json = Nothing
ws.Cells(GetLastRow(ws) + 1, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
Next
End Sub
Public Function GetLastRow(ByVal sh As Worksheet) As Long
On Error Resume Next
GetLastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Please also let me know mistakes I am doing, so that i will take care of those in future.
Short answer:
No.
I would go so far as to say it is impossible you can write something generic for most webs . One could say the generic part is the parser itself. But you need to have some familiarity with the json structure of each endpoint to appropriately direct parsing. Json itself has defined structural syntax/components, but what you want from those will have different access paths and require different handling to do so. Then there are the arguments that may need to be supplied and differences in output format.
What is the best scenario?
If you have a set list of urls (ideally API endpoints) you have a better chance of writing something that might last for a while as you can familiarise yourself with the json returned. But how generic is this? It's really just branched code.
Re-usable stuff:
Might be the non parser stuff which can be generalised e.g. methods and classes you create that parse out the paths for the entire structure and look for key words and return you those paths? Helper functions you write that might recursively write out nested structures etc. Code that makes the request and handles fails etc.... I would definitely recommend looking into classes for re-usable code in web-scraping.
Class based examples:
I will add to this as and when
https://stackoverflow.com/a/52301153/6241235
https://codereview.stackexchange.com/questions/69009/vba-clickbot-featuring-ajax-waiting-and-element-searching
I make a request to a website and paste the JSON response into a single cell.
I get an object required 424 error.
Sub GetJSON()
Dim hReq As Object
Dim JSON As Dictionary
Dim var As Variant
Dim ws As Worksheet
Set ws = Title
'create our URL string and pass the user entered information to it
Dim strUrl As String
strUrl = Range("M24").Value
Set hReq = CreateObject("MSXML2.XMLHTTP")
With hReq
.Open "GET", strUrl, False
.Send
End With
'wrap the response in a JSON root tag "data" to count returned objects
Dim response As String
response = "{""data"":" & hReq.responseText & "}"
Set JSON = JsonConverter.ParseJson(response)
'set array size to accept all returned objects
ReDim var(JSON("data").Count, 1)
Cells(25, 13) = JSON
Erase var
Set var = Nothing
Set hReq = Nothing
Set JSON = Nothing
End Sub
The URL that gives me the response in cell "M24":
https://earthquake.usgs.gov/ws/designmaps/asce7-10.json?latitude=36.497452&longitude=-86.949479&riskCategory=III&siteClass=C&title=Seismic
The code after Qharr's response. I get a run time 0 error even though the error says it ran successfully. Nothing is copied to my cells.
Public Sub GetInfo()
Dim URL As String, json As Object
Dim dict As Object
URL = "https://earthquake.usgs.gov/ws/designmaps/asce7-10.json?latitude=36.497452&longitude=-86.949479&riskCategory=III&siteClass=C&title=Seismic"
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", URL, False
.Send
Set json = JsonConverter.ParseJson(.responseText) '<== dictionary
ThisWorkbook.Worksheets("Title").Cells(1, 1) = .responseText
Set dict = json("response")("data")
ws.Cells(13, 27) = "ss: " & dict("ss") & Chr$(10) & "s1: " & dict("s1")
End With
End Sub
I'm not clear what you mean. The entire response can go in a cell as follows.
JSON is an object so you would need Set keyword but you can't set a cell range to the dictionary object - the source of your error.
Option Explicit
Public Sub GetInfo()
Dim URL As String, json As Object
URL = "https://earthquake.usgs.gov/ws/designmaps/asce7-10.json?latitude=36.497452&longitude=-86.949479&riskCategory=III&siteClass=C&title=Seismic"
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", URL, False
.send
Set json = JsonConverter.ParseJson(.responseText) '<== dictionary
ThisWorkbook.Worksheets("Sheet1").Cells(1, 1) = .responseText
End With
End Sub
When you use parsejson you are converting to a dictionary object which you need to do something with. There is simply too much data nested inside to write anything readable (if limit not exceeded) into one cell.
Inner dictionary data quickly descends into nested collections. The nested collection count comes from
Dim dict As Object
Set dict = json("response")("data")
Debug.Print "nested collection count = " & dict("sdSpectrum").Count + dict("smSpectrum").Count
To get just s1 and ss values parse them out:
Dim dict As Object
Set dict = json("response")("data")
ws.Cells(1, 2) = "ss: " & dict("ss") & Chr$(10) & "s1: " & dict("s1")
I have figured out the solution to pasting the response text with Excel 2003. Below is my finished code.
Public Sub datagrab()
Dim URL As String
Dim ws As Object
Dim xmlhttp As New MSXML2.XMLHTTP60
URL = Range("M24").Value 'This is the URL I'm requesting from
xmlhttp.Open "GET", URL, False
xmlhttp.Send
Worksheets("Title").Range("M25").Value = xmlhttp.responseText
End Sub
I'm trying to get dollar exchange rate from http://www4.bcb.gov.br/pec/taxas/port/ptaxnpesq.asp?id=txcotacao into a Excel spreadsheet.
I tried to paste as refreshable web query, however, the page opens one step earlier with a form, which has default inputs (that work for me) and then the query copies stuff from this page.
I tried to write a code to submit the form. I tried the .submit, .Click, .FireEvent and many other things I found on internet.
I tried to refer to the button by its name, class, tag, ...
<input title="Pesquisar" class="botao" onclick="limparVazio()" type="submit" value="Pesquisar">
I tried to trigger the form directly or bypass it
<form name="consultarBoletimForm" action="/ptax_internet/consultaBoletim.do?method=consultarBoletim" method="post">
You can use the bcb.gov.br Open Data Portal.
Send a request for a JSON response with the conversion rates from their Exchange rates – daily bulletins.
With the received response, amongst other methods, you can then:
Use the JSON Converter and set the convert the response into a JSON object and work with that;
Parse the response as a string with a regex to get the values
Looking at the results for today's rate on the site:
Input:
Output:
Result:
You can see USD 1 = 3,7048 BRL
① Using JSON object:
Example string to make request:
"https://olinda.bcb.gov.br/olinda/service/PTAX/version/v1/odata/ExchangeRatePeriod(moeda=#moeda,dataInicial=#dataInicial,dataFinalCotacao=#dataFinalCotacao)?%40moeda=%27" & TARGET_CURRENCY & "%27&%40dataInicial=%27" & START_DATE & "%27&%40dataFinalCotacao=%27" & END_DATE & "%27&%24format=json"
I include the start date, end date and currency in the string as well as specify the response format as JSON. I have selected the date to match the website view shown in the images above.
The JSON response is as follows:
I read the response into a string variable and then use JsonConverter.ParseJson(strJSON) to convert to a JSON object, stored in json variable. A quick inspection of the structure:
The begining "{" tells me that json is a dictionary.
I can also see that json("value") is a collection of dictionaries and that the value I am interested in, 3,7048 - remember from the website images above, is stored as "cotacaoCompra".
I can thus use the following script to access that value. The JSON response actually gives rates at 5 different times on that date in question. These are all printed out. The Fechamento (Closing) bulletin rate of 3,7048 we can see matches.
Code:
Option Explicit
Public Sub GetInfo()
Dim strURL As String, strJSON As String, item As Variant, http As Object, json As Object
Const TARGET_CURRENCY As String = "USD"
Const START_DATE As String = "06-13-2018"
Const END_DATE As String = "06-13-2018"
strURL = "https://olinda.bcb.gov.br/olinda/service/PTAX/version/v1/odata/ExchangeRatePeriod(moeda=#moeda,dataInicial=#dataInicial,dataFinalCotacao=#dataFinalCotacao)?%40moeda=%27" & TARGET_CURRENCY & "%27&%40dataInicial=%27" & START_DATE & "%27&%40dataFinalCotacao=%27" & END_DATE & "%27&%24format=json"
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", strURL, False
http.send
strJSON = http.responseText
Set json = JsonConverter.ParseJson(strJSON)
For Each item In json("value")
Debug.Print "rate " & item("cotacaoCompra") & " at " & item("dataHoraCotacao")
Next item
End Sub
Script output:
Notes:
Requires JSONConverter bas added and VBE > Tools > References > Microsoft Scripting RunTime)
② Parsing the responseText with a regex to get the rates:
The regex I will use is
"cotacaoCompra":\d{1,}.\d{1,}
This looks for the literal string "cotacaoCompra":, followed by 1 or more numbers then a ".", then one of more numbers.
I then have to remove the string "cotacaoCompra": with a straight forward replace. Ideally, I would just extract the numbers with "(?<=""cotacaoCompra"":)\d{1,}.\d{1,}"; basically, that says after, but not including "cotacaoCompra":. But that doesn't appear to be supported.
With that in mind the script to get the rates with regex:
Code:
Public Sub GetInfo2()
Dim strURL As String, strJSON As String, item As Variant, http As Object, json As Object
Const TARGET_CURRENCY As String = "USD"
Const START_DATE As String = "06-13-2018"
Const END_DATE As String = "06-13-2018"
strURL = "https://olinda.bcb.gov.br/olinda/service/PTAX/version/v1/odata/ExchangeRatePeriod(moeda=#moeda,dataInicial=#dataInicial,dataFinalCotacao=#dataFinalCotacao)?%40moeda=%27" & TARGET_CURRENCY & "%27&%40dataInicial=%27" & START_DATE & "%27&%40dataFinalCotacao=%27" & END_DATE & "%27&%24format=json"
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", strURL, False
http.send
strJSON = http.responseText
Dim Matches As Object
With CreateObject("VBScript.RegExp")
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = """cotacaoCompra"":\d{1,}.\d{1,}" 'The pattern I really wanted, "(?<=""cotacaoCompra"":)\d{1,}.\d{1,}", doesn't appear to be supported
If Not .test(strJSON) Then Exit Sub
Set Matches = .Execute(strJSON)
Dim match As Object
For Each match In Matches
Debug.Print Replace(match, """cotacaoCompra"":", vbNullString)
Next
End With
End Sub
I am coding vba to open the central bank's website and input the values and extract the data, I usually do this on the mail site, bank of Brazil etc ...
() of the central bank
I can not give the input value via vba in the textbox I've already tried:
Ie.Document.all.Item("valueConverter").Innertext="1"
Ie.Document.getElementById("valueConverter").Value="1"
Ie.Document.getElementById("valueConverter")(0).Value="1"
Ie.Document.getElementByName("valueConverter").Value = "1"
The Elements of this site is this:
<Input type = "text" name = "valueConverter" maxlength = "17" size "20" value onkeypress = "return (MascaraMoeda (this, '.', ',', Event)
Does anyone know how?
tl;dr;
I cannot mark this as a duplicate as there is no accepted answer to where I posted an answer to a similar question.
Not sure of the protocol as simply posting a link in the comments doesn't mean it will be found again.
My full answer is here: Excel Web Query Submit Issues
To summarize:
You can use the bcb.gov.br Open Data Portal.
Send a request for a JSON response with the conversion rates from their Exchange rates – daily bulletins.
With the received response, amongst other methods, you can then:
Use the JSON Converter .basa and set the convert the response into a JSON object and work with that
Parse the response as a string with a regex to get the values
For brevity, I will give you just the second method here and you can view my other answer for both methods:
Public Sub GetInfo2()
Dim strURL As String, strJSON As String, item As Variant, http As Object, json As Object
Const TARGET_CURRENCY As String = "USD"
Const START_DATE As String = "06-13-2018"
Const END_DATE As String = "06-13-2018"
strURL = "https://olinda.bcb.gov.br/olinda/service/PTAX/version/v1/odata/ExchangeRatePeriod(moeda=#moeda,dataInicial=#dataInicial,dataFinalCotacao=#dataFinalCotacao)?%40moeda=%27" & TARGET_CURRENCY & "%27&%40dataInicial=%27" & START_DATE & "%27&%40dataFinalCotacao=%27" & END_DATE & "%27&%24format=json"
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", strURL, False
http.send
strJSON = http.responseText
Dim Matches As Object
With CreateObject("VBScript.RegExp")
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = """cotacaoCompra"":\d{1,}.\d{1,}" 'The pattern I really wanted, "(?<=""cotacaoCompra"":)\d{1,}.\d{1,}", doesn't appear to be supported
If Not .test(strJSON) Then Exit Sub
Set Matches = .Execute(strJSON)
Dim match As Object
For Each match In Matches
Debug.Print Replace(match, """cotacaoCompra"":", vbNullString)
Next
End With
End Sub