Parse multiple cells and values from a single JSON-request - json

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.

Related

Parsing JSON into Excel but having an Error

I have been using below code to convert the data from JSON to Excel but below JSON format is not converting into excel and having an error Run time error: Invalid procedure call or argument on the line ws.Cells(r, "C").Value = JSON("sku")
Here is my code that i have been using. I do not know why the error is appearing when it works for other JSON format instead of this one.
Your help will be appreciated.
Dim objRequest As Object
Dim strUrl As String
Dim blnAsync As Boolean
Dim strResponse As String
Dim idno As Long
Dim ws As Worksheet
Dim JSON As Object
Dim lrow As Long
Set ws = Sheet4
lrow = ws.Range("C" & ws.Rows.Count).End(xlUp).Row
Set objRequest = CreateObject("MSXML2.XMLHTTP")
strUrl = "url"
blnAsync = True
With objRequest
.Open "GET", strUrl, blnAsync
.setRequestHeader "Content-Type", "application/json"
.send
While objRequest.readyState <> 4
DoEvents
Wend
strResponse = .ResponseText
End With
Set JSON = ParseJson(strResponse)
' Debug.Print strResponse
r = 2
ws.Cells(r, "C").Value = JSON("sku")
'r = r + 1
I'm not sure if there is a option for this in JSONConverter but as far as I know, it doesn't like to parse JSON string that starts with a collection so I would usually create a key manually so that it will convert properly.
Below example also shows how you can loop through the collection and get the value for sku:
'.... Continue after you post the API...
Dim strResponse As String
strResponse = .responseText
Dim resultDict As Object
Set resultDict = ParseJson("{""result"":" & strResponse & "}")
Dim i As Long
Dim resultNum As Long
resultNum = resultDict("result").Count
For i = 1 To resultNum
Debug.Print resultDict("result")(i)("id")
Debug.Print resultDict("result")(i)("sku")
Debug.Print resultDict("result")(i)("upc")
'Loop through skuList collection
Dim j As Long
For j = 1 To resultDict("result")(i)("skuList").Count
Debug.Print vbTab & resultDict("result")(i)("skuList")(j)("id")
Debug.Print vbTab & resultDict("result")(i)("skuList")(j)("sku")
Debug.Print vbTab & resultDict("result")(i)("skuList")(j)("skuTitle")
Next j
Next i

Parsing JSON data into Excel sheet

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

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.

Having trouble with jsonconverter.bas parsing json with vba excel

Im trying to run the following code but I am getting a type mismatch error:
Public Sub exceljson()
Dim http As Object, JSON As Object, i As Integer
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", "https://wex.nz/api/3/ticker/btc_usd-ltc_usd", False
http.Send
Set JSON = ParseJson(http.responseText)
i = 2
For Each Item In JSON
Sheets(1).Cells(i, 2).Value = Item("high")
Sheets(1).Cells(i, 3).Value = Item("low")
i = i + 1
Next
MsgBox ("complete")
End Sub
The example code below worked fine when I was using it:
Public Sub exceljson()
Dim http As Object, JSON As Object, i As Integer
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", "http://jsonplaceholder.typicode.com/users", False
http.Send
Set JSON = ParseJson(http.responseText)
i = 2
For Each Item In JSON
Sheets(1).Cells(i, 1).Value = Item("id")
Sheets(1).Cells(i, 2).Value = Item("name")
Sheets(1).Cells(i, 3).Value = Item("username")
Sheets(1).Cells(i, 4).Value = Item("email")
Sheets(1).Cells(i, 5).Value = Item("address")("city")
Sheets(1).Cells(i, 6).Value = Item("phone")
Sheets(1).Cells(i, 7).Value = Item("website")
Sheets(1).Cells(i, 8).Value = Item("company")("name")
i = i + 1
Next
MsgBox ("complete")
End Sub
I'm not sure what the difference between the two sites is. Any help would be greatly appreciated.
You need to examine the structure of the JSON more closely.
Because you chose to not specifically declare your Item variable, it gets implicitly declared as a Variant (which is OK in this instance).
In your first macro, the Item is a String so you need to reference that as a key.
In your second macro, the Item will be a Dictionary object, so you can reference it the way you did.
So in your 1st macro, you need something like:
For Each Item In JSON
Sheets(1).Cells(i, 2).Value = JSON(Item)("high")
Sheets(1).Cells(i, 3).Value = JSON(Item)("low")
i = i + 1
Next

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.