Integration of web API into Excel using Macro & VBA - json

Question

I have used link - Parsing JSON to Excel using VBA
to solve my problem, but it is not resolved fully.
Up to JSON Parse it is working as expected then not able to convert it into 2D Array & that's why not able convert JSON data into Excel table.
using code as below,
Option Explicit
Sub GetAPI_Data()
Dim sJSONString As String
Dim sJSONStringTmp1 As String
Dim sJSONStringTmp2 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/Zp0mFEqd", True
.send
Do Until .readyState = 4: DoEvents: Loop
sJSONString = "{ ""EmployeeDetails"": " + .responseText + "}"
Debug.Print sJSONString
End With
Debug.Print sJSONString
' Parse JSON sample
JSON.Parse sJSONString, vJSON, sState
If sState = "Error" Then MsgBox "Invalid JSON": End
' Convert JSON to 2D Array
JSON.toArray vJSON("EmployeeDetails"), 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
My JSON Data as follows,
{
"EmployeeDetails": "[{\"AccountName\":\"CWT COMMODITIES (ANTWERP) N.V.\",\"AccountOwner\":null,\"Age\":\"257\",\"AgreementLevel\":null,\"Amount\":\"1\",\"Amount_converted\":\"1.13\",\"Amount_converted_Currency\":null,\"AmountCurrency\":\"EUR\",\"CloseDate\":\"2022-06-15\",\"CloseMonth\":null,\"CoreTechnology\":null,\"CreatedDate\":\"2021-10-01T07:52:36.000+0000\",\"CustomerIndustry\":\"Infrastructure / Transport\",\"District\":null,\"ePSFBranch_Location\":null,\"ExclusiveHBSTechnology\":null,\"ExpectedProjectDuration\":null,\"FiscalPeriod_Num\":\"6\",\"FiscalYear\":\"2022\",\"ForecastCategory\":\"Pipeline\",\"FPXBranch\":null,\"GrossMargin_Percentage\":null,\"Industry\":\"Education\",\"IndustryCode\":null,\"LeadSource\":null,\"LegacyOpportunityNumber\":null,\"LineofBusiness\":null,\"NextSteps\":null,\"OpportunityName\":\"CWT Onderhoud BRANDDETECTIE\",\"OpportunityOwner\":\"Wim Hespel\",\"OpportunityType\":null,\"OwnerRole\":\"Direct EUR VSK&TTG Sales\",\"PrimarySolutionFamily\":null,\"PrimarySubSolutionFamily\":null,\"Probability_Percentage\":\"5\",\"ProjectEndDate\":\"2022-06-15\",\"ProjectStartDate\":\"2022-06-15\",\"RecordType\":\"Core\",\"Region\":\"Europe\",\"SalesRegion\":\"Belgium & Luxembourg\",\"Stage\":\"1.First Calls\",\"SubRegion\":\"HBS Benelux\",\"OpportunityNumber\":\"0001458471\",\"VerticalMarket\":\"Infrastructure / Transport excluding Airports\",\"Win_LossCategory\":null,\"Win_LossReason\":null,\"Country\":\"Belgium\",\"InitiatedCPQEstimateProcess\":\"False\",\"LastModifiedDate\":\"2022-03-17T15:27:33.000+0000\",\"LocationSS\":null,\"OpportunityCurrency\":null,\"OpportunityID\":\"0065a0000109AMQAA2\",\"OpportunitySubType\":null,\"OwnerID\":\"0051H00000AvuQ2QAJ\",\"RecordTypeId\":\"0121H000001eZ9VQAU\",\"CustomerType\":\"Existing Customer\",\"GBE\":\"HBS\",\"EditedBy\":\"\",\"Field_Or_Event\":\"\",\"OldValue\":\"\",\"NewValue\":\"\",\"EditDate\":\"\",\"LastStageChangeDate\":null,\"StageDuration\":null,\"ExpectedRevenue\":\"0.05\",\"GrossMarginAtSubmission\":null,\"LastActivity\":null,\"OwnerEID\":\"H185118\"}]"
}
Error:
1] on local machine I am getting error in JSON.toArray i.e. not able to create 2D array.
2] while using above code with online JSON Data as per URL then getting only 2 column data which is not proper.
Updated Code
Option Explicit
Sub GetAPI_Data()
Dim sJSONString As String
Dim sJSONStringTmp1 As String
Dim sJSONStringTmp2 As String
Dim vJSON
Dim s
Dim sState As String
Dim aData()
Dim aHeader()
' Retrieve JSON content
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://pastebin.com/raw/Zp0mFEqd", True
.send
Do Until .readyState = 4: DoEvents: Loop
'sJSONString = "{ ""EmployeeDetails"": " + .responseText + "}"
sJSONString = .responseText
Debug.Print sJSONString
End With
' Parse JSON sample
JSON.Parse sJSONString, vJSON, sState
If sState = "Error" Then MsgBox "Invalid JSON": End
Debug.Print vJSON.Item("EmployeeDetails")
'vJSON("EmployeeDetails") = "{ ""EmployeeDetails"": " + vJSON("EmployeeDetails") + "}"
s = vJSON("EmployeeDetails")
s = "{""data"":" & s & "}"
Debug.Print vJSON.Item("EmployeeDetails")
Dim xJSON As Dictionary
'JSON.Parse vJSON("EmployeeDetails"), xJSON, sState
JSON.Parse s, xJSON, sState
If sState = "Error" Then MsgBox "Invalid JSON": End
' Convert JSON to 2D Array
JSON.toArray xJSON, 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
Note : I have updated API with multiple line of JSON
Error:
1] Now I am getting required data.
2] But the main issue is, it is coming only in 2 rows (1 for column header & other one for Data)
3] Requirement is, it should display 5 different rows with first row of header
Please help me out from this.

Answer 1

This worked for me to give a 2D array which could be placed on a worksheet:
Sub Tester()
Dim json As Object, s As String, recs As Object, arr
Set json = ParseJson(GetContent("C:\Temp\json.txt")) 'reading from a file for testing
s = json("EmployeeDetails") 'get the embedded json
Set json = ParseJson("{""data"":" & s & "}") 'parse the embedded json
Set recs = json("data") 'collection of records 'a Collection of records
arr = RecsToArray(recs) 'convert to a 2D array
With Sheet6.Range("A1")
.Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr 'write array to sheet
End With
End Sub
'Convert an array/collection of json objects (dictionaries)
' to a tabular 2D array, with a header row
Function RecsToArray(recs As Collection)
Dim rec, k, i As Long, r As Long, c As Long, arr()
Dim dictCols As Object
Set dictCols = CreateObject("scripting.dictionary")
i = 0
'Collect all field names (checking every record in case some may be either incomplete or contain "extra" fields)
' Assumes all field names are unique per record, and no nested objects/arrays within a record
For Each rec In recs
For Each k In rec
If Not dictCols.Exists(k) Then
i = i + 1
dictCols.Add k, i
End If
Next k
Next rec
'size the output array
ReDim arr(1 To recs.Count + 1, 1 To i)
'Populate the header row
For Each k In dictCols
arr(1, dictCols(k)) = k
Next k
r = 1
'collect the data rows
For Each rec In recs
r = r + 1 'next output row
For Each k In rec
arr(r, dictCols(k)) = rec(k)
Next k
Next rec
RecsToArray = arr
End Function
Function GetContent(f As String) As String
GetContent = CreateObject("scripting.filesystemobject"). _
OpenTextFile(f, 1).ReadAll()
End Function

Answer 2

The very first issue you have is that you put an additional { "EmployeeDetails" …json… } around your JSON that allready has this
sJSONString = "{ ""EmployeeDetails"": " + .responseText + "}"
Don't do that!
Second issue you have is that you have a string encoded JSON inside a JSON:
So your original JSON is:
{
"EmployeeDetails": "[{\"AccountName\":\"CWT COMMODITIES (ANTWERP) N.V.\",\"AccountOwner\":null,\"Age\":\"257\",\"AgreementLevel\":null,\"Amount\":\"1\",\"Amount_converted\":\"1.13\",\"Amount_converted_Currency\":null,\"AmountCurrency\":\"EUR\",\"CloseDate\":\"2022-06-15\",\"CloseMonth\":null,\"CoreTechnology\":null,\"CreatedDate\":\"2021-10-01T07:52:36.000+0000\",\"CustomerIndustry\":\"Infrastructure / Transport\",\"District\":null,\"ePSFBranch_Location\":null,\"ExclusiveHBSTechnology\":null,\"ExpectedProjectDuration\":null,\"FiscalPeriod_Num\":\"6\",\"FiscalYear\":\"2022\",\"ForecastCategory\":\"Pipeline\",\"FPXBranch\":null,\"GrossMargin_Percentage\":null,\"Industry\":\"Education\",\"IndustryCode\":null,\"LeadSource\":null,\"LegacyOpportunityNumber\":null,\"LineofBusiness\":null,\"NextSteps\":null,\"OpportunityName\":\"CWT Onderhoud BRANDDETECTIE\",\"OpportunityOwner\":\"Wim Hespel\",\"OpportunityType\":null,\"OwnerRole\":\"Direct EUR VSK&TTG Sales\",\"PrimarySolutionFamily\":null,\"PrimarySubSolutionFamily\":null,\"Probability_Percentage\":\"5\",\"ProjectEndDate\":\"2022-06-15\",\"ProjectStartDate\":\"2022-06-15\",\"RecordType\":\"Core\",\"Region\":\"Europe\",\"SalesRegion\":\"Belgium & Luxembourg\",\"Stage\":\"1.First Calls\",\"SubRegion\":\"HBS Benelux\",\"OpportunityNumber\":\"0001458471\",\"VerticalMarket\":\"Infrastructure / Transport excluding Airports\",\"Win_LossCategory\":null,\"Win_LossReason\":null,\"Country\":\"Belgium\",\"InitiatedCPQEstimateProcess\":\"False\",\"LastModifiedDate\":\"2022-03-17T15:27:33.000+0000\",\"LocationSS\":null,\"OpportunityCurrency\":null,\"OpportunityID\":\"0065a0000109AMQAA2\",\"OpportunitySubType\":null,\"OwnerID\":\"0051H00000AvuQ2QAJ\",\"RecordTypeId\":\"0121H000001eZ9VQAU\",\"CustomerType\":\"Existing Customer\",\"GBE\":\"HBS\",\"EditedBy\":\"\",\"Field_Or_Event\":\"\",\"OldValue\":\"\",\"NewValue\":\"\",\"EditDate\":\"\",\"LastStageChangeDate\":null,\"StageDuration\":null,\"ExpectedRevenue\":\"0.05\",\"GrossMarginAtSubmission\":null,\"LastActivity\":null,\"OwnerEID\":\"H185118\"}]"
}
and what you get out of vJSON.Item("EmployeeDetails") is
[
{
"AccountName": "CWT COMMODITIES (ANTWERP) N.V.",
"AccountOwner": null,
"Age": "257",
"AgreementLevel": null,
"Amount": "1",
"Amount_converted": "1.13",
"Amount_converted_Currency": null,
"AmountCurrency": "EUR",
"CloseDate": "2022-06-15",
"CloseMonth": null,
"CoreTechnology": null,
"CreatedDate": "2021-10-01T07:52:36.000+0000",
"CustomerIndustry": "Infrastructure / Transport",
"District": null,
"ePSFBranch_Location": null,
"ExclusiveHBSTechnology": null,
"ExpectedProjectDuration": null,
"FiscalPeriod_Num": "6",
"FiscalYear": "2022",
"ForecastCategory": "Pipeline",
"FPXBranch": null,
"GrossMargin_Percentage": null,
"Industry": "Education",
"IndustryCode": null,
"LeadSource": null,
"LegacyOpportunityNumber": null,
"LineofBusiness": null,
"NextSteps": null,
"OpportunityName": "CWT Onderhoud BRANDDETECTIE",
"OpportunityOwner": "Wim Hespel",
"OpportunityType": null,
"OwnerRole": "Direct EUR VSK&TTG Sales",
"PrimarySolutionFamily": null,
"PrimarySubSolutionFamily": null,
"Probability_Percentage": "5",
"ProjectEndDate": "2022-06-15",
"ProjectStartDate": "2022-06-15",
"RecordType": "Core",
"Region": "Europe",
"SalesRegion": "Belgium & Luxembourg",
"Stage": "1.First Calls",
"SubRegion": "HBS Benelux",
"OpportunityNumber": "0001458471",
"VerticalMarket": "Infrastructure / Transport excluding Airports",
"Win_LossCategory": null,
"Win_LossReason": null,
"Country": "Belgium",
"InitiatedCPQEstimateProcess": "False",
"LastModifiedDate": "2022-03-17T15:27:33.000+0000",
"LocationSS": null,
"OpportunityCurrency": null,
"OpportunityID": "0065a0000109AMQAA2",
"OpportunitySubType": null,
"OwnerID": "0051H00000AvuQ2QAJ",
"RecordTypeId": "0121H000001eZ9VQAU",
"CustomerType": "Existing Customer",
"GBE": "HBS",
"EditedBy": "",
"Field_Or_Event": "",
"OldValue": "",
"NewValue": "",
"EditDate": "",
"LastStageChangeDate": null,
"StageDuration": null,
"ExpectedRevenue": "0.05",
"GrossMarginAtSubmission": null,
"LastActivity": null,
"OwnerEID": "H185118"
}
]
Which you will need to parse again because this still is JSON!
But the converter you use does not accept the JSON to start with [ and thats another issue here. Because if I strip that brackets off so the [ ] in the beginning and end are gone and parse that again it will work:
Sub GetAPI_Data()
Dim sJSONString As String
Dim sJSONStringTmp1 As String
Dim sJSONStringTmp2 As String
Dim vJSON As Dictionary
Dim sState As String
Dim aData()
Dim aHeader()
' Retrieve JSON content
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://pastebin.com/raw/Zp0mFEqd", True
.send
Do Until .readyState = 4: DoEvents: Loop
'sJSONString = "{ ""EmployeeDetails"": " + .responseText + "}" 'don't do this!
sJSONString = .responseText
End With
Debug.Print sJSONString
' Parse JSON sample
JSON.Parse sJSONString, vJSON, sState
If sState = "Error" Then MsgBox "Invalid JSON": End
Debug.Print vJSON.Item("EmployeeDetails")
Dim StripOffOuterBrackets As String
StripOffOuterBrackets = Mid(vJSON.Item("EmployeeDetails"), 2, Len(vJSON.Item("EmployeeDetails")) - 2)
Debug.Print StripOffOuterBrackets
Dim xJSON As Dictionary
JSON.Parse StripOffOuterBrackets, xJSON, sState
If sState = "Error" Then MsgBox "Invalid JSON": End
' Convert JSON to 2D Array
JSON.ToArray xJSON, aData, aHeader
' Output to worksheet #1
Output aHeader, aData, ThisWorkbook.Sheets(1)
MsgBox "Completed"
End Sub
And it outputs the following (and some more lines)