Parsing JSON data into Excel sheet - json

I'm trying to extract JSON data into Excel sheet as table by using the following code.
Sub test()
Dim httpObject As Object
Set httpObject = CreateObject("MSXML2.XMLHTTP")
sURL = "https://www.nseindia.com/live_market/dynaContent/live_watch/stock_watch/foSecStockWatch.json"
sRequest = sURL
httpObject.Open "GET", sRequest, False
httpObject.send
sGetResult = httpObject.responseText
Dim oJSON As Object
Set oJSON = JsonConverter.ParseJson(sGetResult)
i = 2
For Each sItem In oJSON
dItemString = oJSON(sItem)("symbol")
sItemValue = oJSON(sItem)("open")
vItemValue = oJSON(sItem)("high")
xItemValue = oJSON(sItem)("low")
Cells(i, 1) = dItemString
Cells(i, 2) = sItemValue
Cells(i, 3) = vItemValue
Cells(i, 4) = xItemValue
i = i + 1
Next
End Sub
However, I'm getting the below error!
Why I'm getting this error? Kindly advise

First of all you need to examine the structure of the JSON response, using any online JSON viewer (e. g. http://jsonviewer.stack.hu/), where you can see that your JSON object contains data array, and several properties with scalar values:
Going further there are objects within data array, each of them contains some properties that can be populated in rows on the worksheet:
Here is VBA example showing how that values could be retrieved. Import JSON.bas module into the VBA project for JSON processing.
Option Explicit
Sub Test()
Dim sJSONString As String
Dim vJSON
Dim sState As String
Dim aData()
Dim aHeader()
Dim vResult
' Retrieve JSON content
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://www.nseindia.com/live_market/dynaContent/live_watch/stock_watch/foSecStockWatch.json", True
.send
Do Until .readyState = 4: DoEvents: Loop
sJSONString = .responseText
End With
' Parse JSON sample
JSON.Parse sJSONString, vJSON, sState
If sState = "Error" Then MsgBox "Invalid JSON": End
' Convert raw JSON to 2d array and output to worksheet #1
JSON.ToArray vJSON("data"), aData, aHeader
With ThisWorkbook.Sheets(1)
.Cells.Delete
.Cells.WrapText = False
OutputArray .Cells(1, 1), aHeader
Output2DArray .Cells(2, 1), aData
.Columns.AutoFit
End With
MsgBox "Completed"
End Sub
Sub OutputArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize(1, UBound(aCells) - LBound(aCells) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
Sub Output2DArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize( _
UBound(aCells, 1) - LBound(aCells, 1) + 1, _
UBound(aCells, 2) - LBound(aCells, 2) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
The output for data array for me is as follows:
BTW, the similar approach applied in other answers.

I pasted your code into a test module and then imported the JsonConverter as an additional module in my empty workbook. The error you're getting is likely because you need to add the "Microsoft Scripting Runtime" library to your workbook. In the VBE go to the Tools-->References... menu and then scroll down and put a check mark next to the library. After doing this, your code parsed the JSON without issue.
However it did fail in your loop.
I highly recommend that you use Option Explicit at the top of your module. The variable types you think you're using (because I see you're attempting to use Hungarian notation) are not the types of the actual data necessarily. My suggestion is to use descriptive names for the variables to avoid confusion. Additionally, you should be looping on the oJSON("data") structure (which is a Collection by the way). Here is my suggestions put into practice:
Option Explicit
Sub test()
Dim httpObject As Object
Set httpObject = CreateObject("MSXML2.XMLHTTP")
Dim sURL As String
sURL = "https://www.nseindia.com/live_market/dynaContent/" & _
"live_watch/stock_watch/foSecStockWatch.json"
Dim sRequest As String
sRequest = sURL
httpObject.Open "GET", sRequest, False
httpObject.send
Dim sGetResult As String
sGetResult = httpObject.responseText
Dim oJSON As Object
Set oJSON = JsonConverter.ParseJson(sGetResult)
Dim i As Long
i = 2
Dim dataItem As Variant
Dim symbolName As String
Dim openValue As Double
Dim highValue As Double
Dim lowValue As Variant
For Each dataItem In oJSON("data")
symbolName = dataItem("symbol")
openValue = dataItem("open")
highValue = dataItem("high")
lowValue = dataItem("low")
Cells(i, 1) = symbolName
Cells(i, 2) = openValue
Cells(i, 3) = highValue
Cells(i, 4) = lowValue
i = i + 1
Next
End Sub

Related

Parsing JSON to Excel using VBA

I'm having some trouble with parsing JSON data in VBA. I have tried all of the examples online but I'm still unable to solve the issue. What I have managed to do is pull the JSON data into excel in the original format using another VBA code that pulled in data from another website. I've pasted the code that works below. It's not very clean and it has some duplication because I was just trying to see if I could pull the data.
All of the attempts I have tried to use VBA to parse the data have failed with a variety of errors depending on the approach I took. I'd be very grateful if someone could give me some advice on the simplest way to parse the data I've managed to pull. All I need is the data in columns which I can then use in other sheets in the worbook. I've attached a picture of the data that I've pulled. I have managed to parse JSON data from another webpage and in the code I included each column heading for the JSON data. For this new webpage, the JSON data is nested and there are loads of unique rows so I've not taken this approach. Many thanks
[Sub JSONPull()
Dim WB As Workbook, ws As Worksheet, ws2 As Worksheet, qtb As QueryTable
Dim FC As String, sDate As String, eDate As String, Dockmasterurl As String, Performance As Worksheet
Set WB = Application.ThisWorkbook
Set ws = WB.Sheets("Control")
FC = ws.Range("B5")
sDate = ws.Range("B14")
eDate = ws.Range("B15")
Dim sJSONString As String
Dim vJSON
Dim sState As String
Dim aData()
Dim aHeader()
Dim vResult
Dockmasterurl = "https://fc-inbound-dock-execution-service-eu-eug1-dub.dub.proxy.amazon.com/appointment/bySearchParams?warehouseId=" & FC & "&clientId=dockmaster&localStartDate=" & sDate & "T00%3A00%3A00&localEndDate=" & eDate & "T08%3A00%3A00&isStartInRange=false&searchResultLevel=FULL"
Set ws2 = Sheets("JSON")
ws2.Cells.ClearContents
Set qtb = ws2.QueryTables.Add("URL;" & Dockmasterurl, ws2.Range("A1"))
With qtb
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = True
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
ws2.Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, textqualifier:=xlDoubleQuote, consecutivedelimiter:=False, comma:=True, trailingminusnumbers:=True
ws2.Range("A:S").EntireColumn.AutoFit
For Each qtb In ws2.QueryTables
qtb.Delete
Next
End Sub][1]
Here is VBA example showing how the JSON sample by the link can be converted to 2D array and output to worksheet. Import JSON.bas module into the VBA project for JSON processing.
Option Explicit
Sub Test()
Dim sJSONString As String
Dim vJSON
Dim sState As String
Dim aData()
Dim aHeader()
' Retrieve JSON content
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://pastebin.com/raw/hA2UEDXy", True
.send
Do Until .readyState = 4: DoEvents: Loop
sJSONString = .responseText
End With
' Parse JSON sample
JSON.Parse sJSONString, vJSON, sState
If sState = "Error" Then MsgBox "Invalid JSON": End
' Convert JSON to 2D Array
JSON.ToArray vJSON("AppointmentList"), aData, aHeader
' Output to worksheet #1
Output aHeader, aData, ThisWorkbook.Sheets(1)
MsgBox "Completed"
End Sub
Sub Output(aHeader, aData, oDestWorksheet As Worksheet)
With oDestWorksheet
.Activate
.Cells.Delete
With .Cells(1, 1)
.Resize(1, UBound(aHeader) - LBound(aHeader) + 1).Value = aHeader
.Offset(1, 0).Resize( _
UBound(aData, 1) - LBound(aData, 1) + 1, _
UBound(aData, 2) - LBound(aData, 2) + 1 _
).Value = aData
End With
.Columns.AutoFit
End With
End Sub
The output for me is as follows (click to enlarge):
BTW, the similar approach applied in other answers.

How to set a variable equal to a json value from another variable excel vba

The json I am parsing is at this URL https://reqres.in/api/users?page=2. I am using the following code to parse it.
Option Explicit
Sub Test_LateBinding()
Dim objRequest As Object
Dim strUrl As String
Dim blnAsync As Boolean
Dim strResponse As String
Set objRequest = CreateObject("MSXML2.XMLHTTP")
strUrl = "https://reqres.in/api/users?page=2"
blnAsync = True
With objRequest
.Open "GET", strUrl, blnAsync
.SetRequestHeader "Content-Type", "application/json"
.Send
'spin wheels whilst waiting for response
While objRequest.readyState <> 4
DoEvents
Wend
strResponse = .ResponseText
End With
Debug.Print strResponse
End Sub
I can successfully get the json into the strResponse variable. But lets say I want a variable that is equal to "Eve" which is under first name in the json string. How can I set a variable firstName = "Eve" from that json string.
If you need to work with JSON in VBA then I would recommend using this library:
https://github.com/VBA-tools/VBA-JSON
A simple example using that library:
Public Sub Tester()
Dim http As Object, JSON As Object, d
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", "https://reqres.in/api/users?page=2", False
http.SetRequestHeader "Content-Type", "application/json"
http.Send
Set JSON = ParseJson(http.responseText)
For Each d In JSON("data")
Debug.Print d("id"), d("first_name")
Next
End Sub
Here is VBA example showing how that values could be retrieved. Import JSON.bas module into the VBA project for JSON processing.
Option Explicit
Sub Test()
Dim sJSONString As String
Dim vJSON
Dim sState As String
Dim aItems
Dim firstName As String
Dim oItem
Dim i As Long
Dim aData()
Dim aHeader()
' Retrieve JSON content
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://reqres.in/api/users?page=2", True
.send
Do Until .readyState = 4: DoEvents: Loop
sJSONString = .responseText
End With
' Parse JSON sample
JSON.Parse sJSONString, vJSON, sState
If sState = "Error" Then
MsgBox "Invalid JSON"
End
End If
' Process objects in array
' Get 'data' array of objects, there is no Set keyword for arrays
aItems = vJSON("data")
' Access specific item 'first_name' property
firstName = aItems(0)("first_name")
Debug.Print firstName
' Access each item 'first_name' property
For Each oItem In aItems
firstName = oItem("first_name")
Debug.Print firstName
Next
' Convert array of objects to 2d array
JSON.ToArray aItems, aData, aHeader
' Access each item element with index 1, which corresponds to 'first_name' property
For i = 0 To UBound(aData, 1)
firstName = aData(i, 1)
Debug.Print firstName
Next
' Output 2d array to first worksheet
With ThisWorkbook.Sheets(1)
.Cells.Delete
.Cells.WrapText = False
OutputArray .Cells(1, 1), aHeader
Output2DArray .Cells(2, 1), aData
.Columns.AutoFit
End With
MsgBox "Completed"
End Sub
Sub OutputArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize(1, UBound(aCells) - LBound(aCells) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
Sub Output2DArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize( _
UBound(aCells, 1) - LBound(aCells, 1) + 1, _
UBound(aCells, 2) - LBound(aCells, 2) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
BTW, the similar approach applied in other answers.

Parse multiple cells and values from a single JSON-request

I would like to display the following variables from a JSON-request; "time", "open", "high", "low", "close", "volumefrom", "volumeto" in respectively the following columns B, C, D, E, F, G and H.
The request:
https://min-api.cryptocompare.com/data/histoday?fsym=BTC&tsym=USD&limit=60&aggregate=3&e=CCCAGG
So, I would like to see for example the values of "open" located in C2:C51.
I wrote the following macro:
Sub OHLCdata()
Dim strURL As String
Dim strJSON As String
Dim strCurrency As String
Dim strLength As Integer
Dim i As Integer
Dim http As Object
strURL = "https://min-api.cryptocompare.com/data/histoday?fsym=" & strTicker & "&tsym=" & strCurrency & "&limit=" & strLength & "&aggregate=3&e=CCCAGG"
strTicker = Range("A2")
strCurrency = Range("A3")
strLength = Range("A4")
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", strURL, False
http.Send
strJSON = http.responsetext
Set JSON = JsonConverter.ParseJson(strJSON)
i = 2
For Each Item In JSON("DATA")
Sheets(1).Cells(i, 1).Value = Item("time")
Sheets(1).Cells(i, 2).Value = Item("open")
Sheets(1).Cells(i, 3).Value = Item("high")
Sheets(1).Cells(i, 4).Value = Item("low")
Sheets(1).Cells(i, 5).Value = Item("close")
Sheets(1).Cells(i, 6).Value = Item("volumefrom")
Sheets(1).Cells(i, 7).Value = Item("volumeto")
i = i + 1
Next
End Sub
Unfortunately, the macro doesn't work as debugging shows that there is an error in the following line:
For Each Item In JSON("DATA")
However, I need to refer to ("Data") right?
{"Response":"Success","Type":100,"Aggregated":true,**"Data"**:[{"time":1493769600,"close":1507.77,"high":1609.84,"low":1424.05,"open":1445.93,"volumefrom":338807.89999999997,"volumeto":523652428.9200001},
Can anyone explain to me what I am doing wrong? Thanks in advance,
Can anyone explain to me what I am doing wrong?
You are close:
I suspect you probably did a copy/paste on the JSON parser rather than downloading the *.bas file and importing it. If you copied the file and then pasted it into a module, you would see the line Attribute VB_Name = "JsonConverter" Although legal in the .bas file, it is not in a module, hence the *"compile error: invalid inside procedure." * error message.
You create strURL before you define the variables that are included. Therefore the variables will be blank
Your column numbers are off when you write the results, so it will start in column A instead of B.
You fail to declare some of your variables.
Since JSON is a dictionary type object, the key will be case sensitive (unless you declare it to be otherwise). Hence DATA and Data are two different keys. You need to use Data.
Here is your code with the changes; and don't forget to import the .bas file and don't copy/paste.
Option Explicit
Sub OHLCdata()
Dim strURL As String
Dim strJSON As String
Dim strCurrency As String
Dim strLength As Integer
Dim strTicker As String
Dim i As Integer
Dim http As Object
Dim JSON As Dictionary, Item As Dictionary
strTicker = Range("A2")
strCurrency = Range("A3")
strLength = Range("A4")
strURL = "https://min-api.cryptocompare.com/data/histoday?fsym=" & strTicker & "&tsym=" & strCurrency & "&limit=" & strLength & "&aggregate=3&e=CCCAGG"
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", strURL, False
http.Send
strJSON = http.responsetext
Set JSON = JsonConverter.ParseJson(strJSON)
i = 2
For Each Item In JSON("Data")
Sheets(1).Cells(i, 2).Value = Item("time")
Sheets(1).Cells(i, 3).Value = Item("open")
Sheets(1).Cells(i, 4).Value = Item("high")
Sheets(1).Cells(i, 5).Value = Item("low")
Sheets(1).Cells(i, 6).Value = Item("close")
Sheets(1).Cells(i, 7).Value = Item("volumefrom")
Sheets(1).Cells(i, 8).Value = Item("volumeto")
i = i + 1
Next
End Sub
Note: With regard to the Attribute line visible in the bas file if you open it in a text editor, you may refer to Chip Pearson's article on Code Attributes For The VBA Object Browser. It is generally considered bad form to refer to an external link, as they may disappear. However, I could not find a good discussion here on SO. If I have missed it, someone please comment and I will edit this.
You may get JSON data into arrays and output as shown in the example code below. Import JSON.bas module into the VBA project for JSON processing.
Option Explicit
Sub OHLCdata()
Dim sJSONString As String
Dim vJSON As Variant
Dim sState As String
Dim aData()
Dim aHeader()
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://min-api.cryptocompare.com/data/histoday?fsym=BTC&tsym=USD&limit=60&aggregate=3&e=CCCAGG", False
.send
sJSONString = .responseText
End With
JSON.Parse sJSONString, vJSON, sState
vJSON = vJSON("Data")
JSON.ToArray vJSON, aData, aHeader
With Sheets(1)
.Cells.Delete
.Cells.WrapText = False
OutputArray .Cells(1, 1), aHeader
Output2DArray .Cells(2, 1), aData
.Columns.AutoFit
End With
End Sub
Sub OutputArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize(1, UBound(aCells) - LBound(aCells) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
Sub Output2DArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize( _
UBound(aCells, 1) - LBound(aCells, 1) + 1, _
UBound(aCells, 2) - LBound(aCells, 2) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
Here is the output for me:
BTW, the similar approach applied in other answers.

Extract data locations from map

I want to extract data from a map then get and store the locations all charging station in a specific state. (eg: https://www.plugshare.com/)
How can this be done? I don't mind using any programming language but which one is the best one for this application?
You can retrieve the data directly from https://www.plugshare.com with XHRs. You have to look into a little how does a website work to scrape the data. For any dynamically loaded data you just inspect XHRs the webpage does, find the one containing the relevant data, make the same XHR (either site provides API or not) and parse response. Navigate the page e. g. in Chrome, then open Developer Tools window (F12), Network tab, reload F5 the page and examine XHRs in the list.
There is one of the requests to URL https://www.plugshare.com/api/locations/region?... that returns latitude, longitude and other info for charging stations in a rectangle viewport area with specified coordinates. You can find URL, query parameters and some necessary headers as shown below:
Response is in JSON format:
You need to add basic authorization header to request. To retrieve the credentials go to Sources tab, add XHR Breakpoint for URL contains https://www.plugshare.com/api/locations/region, reload F5 the page, when the page is paused on XHR, follow the Call Stack frame by frame:
Skip any NREUM and nrWrapper objects that are the part of New Relic functionality. Click pretty-print {} to format source. Search e. g. Basic, Authorization or setRequestHeader in the sources, for that particular case first match is found in https://www.plugshare.com/js/main.js?_=1:
Click a station on the map and you get one more XHR appeared with URL like https://www.plugshare.com/api/locations/[id] with detailed information for that station, as shown below:
Response is in JSON format also:
Also you may get data for stations from URL like https://www.plugshare.com/api/stations/[id].
You may use the below VBA code to retrieve info as described above. Import JSON.bas module into the VBA project for JSON processing.
Option Explicit
Sub Test_www_plugshare_com()
Const Transposed = False ' Output option
Const Detailed = True ' Scrape option
Dim sResponse As String
Dim aQryHds()
Dim oQuery As Object
Dim sQuery As String
Dim vRegionJSON
Dim sState As String
Dim aResult()
Dim i As Long
Dim vLocationJSON
Dim aRows()
Dim aHeader()
' Retrieve auth token
XmlHttpRequest "GET", "https://www.plugshare.com/js/main.js?_=1", "", "", "", sResponse
With RegExMatches(sResponse, "var s\=""(Basic [^""]*)"";") ' var s="Basic *";
If .Count > 0 Then
aQryHds = Array( _
Array("Authorization", .Item(0).SubMatches(0)), _
Array("Accept", "application/json") _
)
Else
MsgBox "Can't retrieve auth token"
Exit Sub
End If
End With
' Set query parameters
Set oQuery = CreateObject("Scripting.Dictionary")
With oQuery
.Add "minimal", "1"
.Add "count", "500"
.Add "latitude", "19.697593650121235"
.Add "longitude", "-155.06529816792295"
.Add "spanLng", "0.274658203125"
.Add "spanLat", "0.11878815323507652"
.Add "access", "1,3"
.Add "outlets", "[{""connector"":1},{""connector"":2},{""connector"":3},{""connector"":4},{""connector"":5},{""connector"":6,""power"":0},{""connector"":6,""power"":1},{""connector"":7},{""connector"":8},{""connector"":9},{""connector"":10},{""connector"":11},{""connector"":12},{""connector"":13},{""connector"":14},{""connector"":15}]"
.Add "fast", "add"
End With
sQuery = EncodeQueryParams(oQuery)
' Retrieve a list of stations for the viewport
XmlHttpRequest "GET", "https://www.plugshare.com/api/locations/region?" & sQuery, aQryHds, "", "", sResponse
' Parse JSON response
JSON.Parse sResponse, vRegionJSON, sState
If sState <> "Array" Then
MsgBox "Invalid JSON response"
Exit Sub
End If
' Populate result array
ReDim aResult(UBound(vRegionJSON))
' Extract selected properties from parsed JSON
For i = 0 To UBound(aResult)
Set aResult(i) = ExtractKeys(vRegionJSON(i), Array("id", "name", "latitude", "longitude"))
DoEvents
Next
If Detailed Then
' Populate result array with detailed info for each location
For i = 0 To UBound(aResult)
' Retrieve detailed info for each location
XmlHttpRequest "GET", "https://www.plugshare.com/api/locations/" & aResult(i)("id"), aQryHds, "", "", sResponse
' Parse JSON response
JSON.Parse sResponse, vLocationJSON, sState
If sState = "Object" Then
' Extract selected properties from parsed JSON
Set aResult(i) = ExtractKeys(vLocationJSON, Array("reverse_geocoded_address", "hours", "phone", "description"), aResult(i))
End If
DoEvents
Next
End If
' Convert resulting array to arrays for output
JSON.ToArray aResult, aRows, aHeader
' Output
With ThisWorkbook.Sheets(1)
.Cells.Delete
If Transposed Then
Output2DArray .Cells(1, 1), WorksheetFunction.Transpose(aHeader)
Output2DArray .Cells(1, 2), WorksheetFunction.Transpose(aRows)
Else
OutputArray .Cells(1, 1), aHeader
Output2DArray .Cells(2, 1), aRows
End If
.Columns.AutoFit
End With
MsgBox "Completed"
End Sub
Sub XmlHttpRequest(sMethod As String, sUrl As String, arrSetHeaders, sFormData, sRespHeaders As String, sContent As String)
Dim arrHeader
'With CreateObject("Msxml2.ServerXMLHTTP")
' .SetOption 2, 13056 ' SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS
With CreateObject("MSXML2.XMLHTTP")
.Open sMethod, sUrl, False
If IsArray(arrSetHeaders) Then
For Each arrHeader In arrSetHeaders
.SetRequestHeader arrHeader(0), arrHeader(1)
Next
End If
.send sFormData
sRespHeaders = .GetAllResponseHeaders
sContent = .responseText
End With
End Sub
Function RegExMatches(sText, sPattern, Optional bGlobal = True, Optional bMultiLine = True, Optional bIgnoreCase = True) As Object
With CreateObject("VBScript.RegExp")
.Global = bGlobal
.MultiLine = bMultiLine
.IgnoreCase = bIgnoreCase
.Pattern = sPattern
Set RegExMatches = .Execute(sText)
End With
End Function
Function EncodeQueryParams(oParams As Object) As String
Dim aParams
Dim i As Long
aParams = oParams.Keys()
For i = 0 To UBound(aParams)
aParams(i) = EncodeUriComponent((aParams(i))) & "=" & EncodeUriComponent((oParams(aParams(i))))
Next
EncodeQueryParams = Join(aParams, "&")
End Function
Function EncodeUriComponent(strText As String) As String
Static objHtmlfile As Object
If objHtmlfile Is Nothing Then
Set objHtmlfile = CreateObject("htmlfile")
objHtmlfile.parentWindow.execScript "function encode(s) {return encodeURIComponent(s)}", "jscript"
End If
EncodeUriComponent = objHtmlfile.parentWindow.encode(strText)
End Function
Function ExtractKeys(oSource, aKeys, Optional oTarget = Nothing) As Object
Dim vKey
If oTarget Is Nothing Then Set oTarget = CreateObject("Scripting.Dictionary")
For Each vKey In aKeys
If oSource.Exists(vKey) Then
If IsObject(oSource(vKey)) Then
Set oTarget(vKey) = oSource(vKey)
Else
oTarget(vKey) = oSource(vKey)
End If
End If
Next
Set ExtractKeys = oTarget
End Function
Sub OutputArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize(1, UBound(aCells) - LBound(aCells) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
Sub Output2DArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize( _
UBound(aCells, 1) - LBound(aCells, 1) + 1, _
UBound(aCells, 2) - LBound(aCells, 2) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
Change to Const Detailed = False if you have a lot of items for output to prevent application hanging, since XHRs are in synchronous mode. The output for me with specified viewport coordinates is as follows:
BTW, the similar approach applied in other answers.

Use XML HTTP Request On Sites That Require Object Interaction

I am working on a project to scrape information from a number of websites. I have a number of sites working with no issue, largely processing them by amending the URL to pass through the relevant criteria or by posting AJAX requests. I am fairly new to this so I am seeking some assistance.
I have come across a website where I need to interact with objects on a page in order to obtain further information. An example of this is the below site:
Example Site
If you visit the site and go to the bottom there are more brands and clicking "view" will display additional products. The HTML for these is only returned once clicked.
With other sites I have sourced information from I have used the below approach. Is there a way to process the page via the XML HTTP Method after a page object action has been performed?
Any help would be greatly appreciated. At the moment I am assuming I will have to stick to scraping such sites using an Internet Explorer object.
Option Explicit
Public Sub sbKF()
Dim conn As ADODB.Connection
Dim rsIn As ADODB.Recordset
Dim HTMLDoc As HTMLDocument
Dim strUrl As String
Dim strPost As String
Set conn = CurrentProject.Connection
Set rsIn = New ADODB.Recordset
Set HTMLDoc = New MSHTML.HTMLDocument
rsIn.Open pcstrInput, conn, adOpenStatic, adLockReadOnly
rsIn.MoveLast: rsIn.MoveFirst
Do While Not rsIn.EOF
' Create the URL and Post submission for input size.
strUrl = "http://www.[Site].com"
strPost = "Stage=2&sop=TyreSize&ssq=1&vnp=&vmk=&vch=&vmo=&drd="
' Return the Document body results
HTMLDoc.body.innerHTML = fnPostXmlHttp(strUrl, strPost)
rsIn.MoveNext
Loop
End Sub
Public Function fnPostXmlHttp(ByVal strUrl As String, ByVal strScript As String)
Dim XMLHttpRequest As Object
Dim strOut As String
Set XMLHttpRequest = CreateObject("MSXML2.XMLHTTP")
XMLHttpRequest.Open "POST", strUrl, False
XMLHttpRequest.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
XMLHttpRequest.send (strScript)
While XMLHttpRequest.ReadyState <> 4
DoEvents
Wend
fnPostXmlHttp = XMLHttpRequest.responseText
End Function
If you take a look at www.blackcircles.com HTML response, you will see the javascript snippet:
...
var newTyresActionUrl;
var lookupAddress;
$(document).ready(function () {
newTyresActionUrl = new BC.classes.productV6SearchPage('https://www.blackcircles.com/order/tyres',
{"Error":false,"VariantFitments":[{"Name":"All Season","VariantType":11,"SeasonalType":true,"TruckType":false,"FriendlyName":"allseason","Count":17,
...
"TakeoverCss":"\u003clink id=\"brandtakeover-css\" rel=\u0027stylesheet\u0027 type=\u0027text/css\u0027 href=\u0027/templates/bcstyles/css/goodyear-effgrip-perf.css\u0027\u003e"},
"Width",
"Profile",
"Rim",
"Speed",
"Method",
true,
""
);
addToBasket = new BC.classes.addtobasket('https://www.blackcircles.com/order/tyres', "order", '/truck/garages');
...
Actually the portion within curly braces represents a JSON object containing all displayed on the webpage data. So you can extract that JSON string from HTML content by Instr(), parse it, convert to arrays and output to the worksheet, as shown in the example code below. Import JSON.bas module into the VBA project for JSON processing.
Option Explicit
Sub Test_blackcircles()
Dim sResp As String
Dim vJSON As Variant
Dim sState As String
Dim i As Long
Dim vItem
Dim aData()
Dim aHeader()
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://www.blackcircles.com/order/tyres/search?width=205&profile=55&rim=R16&speed=V&vehicle-make=&postcode=&delivery=1&findTyre=", False
.send
sResp = .responseText
End With
sResp = getFragment(sResp, "new BC.classes.productV6SearchPage", "new BC.classes.addtobasket")
sResp = getFragment(sResp, "{", "}")
sResp = "{" & sResp & "}"
JSON.Parse sResp, vJSON, sState
i = 1
With Sheets(1)
.Cells.Delete
.Cells.WrapText = False
For Each vItem In Array( _
"Manufacturers", _
"CarManufacturers", _
"All", _
"Deals", _
"Best", _
"Rest", _
"SearchParams" _
)
.Cells(i, 1).Value = vItem
JSON.ToArray vJSON(vItem), aData, aHeader
OutputArray .Cells(i + 2, 1), aHeader
Output2DArray .Cells(i + 3, 1), aData
.Columns.AutoFit
i = i + UBound(aData, 1) + 5
Next
End With
End Sub
Sub OutputArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize(1, UBound(aCells) - LBound(aCells) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
Sub Output2DArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize( _
UBound(aCells, 1) - LBound(aCells, 1) + 1, _
UBound(aCells, 2) - LBound(aCells, 2) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
Function getFragment( _
sourceText As String, _
startPattern As String, _
endPattern As String _
) As String
Dim startPos
startPos = InStr(sourceText, startPattern)
If startPos = 0 Then Exit Function
Dim partText
partText = Mid(sourceText, startPos + Len(startPattern))
Dim endPos
endPos = InStrRev(partText, endPattern)
If endPos = 0 Then Exit Function
getFragment = Left(partText, endPos - 1)
End Function
BTW, the similar approach applied in other answers.