Integration of web API into Excel using Macro & VBA

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)