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.
EmployeeDetailsproperty You may need to extract that and parse it before processing the data.