使用宏将网络 API 集成到 Excel 中 & VBA
Integration of web API into Excel using Macro & VBA
我用过link - Parsing JSON to Excel using VBA
解决我的问题，但没有完全解决。
最多 JSON 解析它按预期工作然后无法将其转换为二维数组 & 这就是为什么无法将 JSON 数据转换为 Excel table.
使用如下代码，
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
我的JSON数据如下，
{
"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\"}]"
}
错误：
1] 在本地机器上我在 JSON.toArray 中收到错误，即无法创建二维数组。
2] 当根据 URL 将上述代码与在线 JSON 数据一起使用时，只得到 2 列数据，这是不正确的。
更新代码
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
注意：我已经用多行 JSON
更新了 API
错误：
1] 现在我正在获取所需的数据。
2] 但主要问题是，它只出现在 2 行中（1 列用于 header 列，另一行用于数据）
3] 要求是，它应该显示 5 个不同的行，第一行 header
请帮我解决这个问题。
您遇到的第一个问题是您在 JSON 周围放置了一个额外的 { "EmployeeDetails" …json… }，而这个
sJSONString = "{ ""EmployeeDetails"": " + .responseText + "}"
不要那样做！
您遇到的第二个问题是您在 JSON:
中有一个编码为 JSON 的字符串
所以你原来的JSON是：
{
"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\"}]"
}
你从 vJSON.Item("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"
}
]
您需要再次解析，因为这仍然是 JSON!
但是您使用的转换器不接受 JSON 以 [ 开头，这是另一个问题。因为如果我去掉括号，那么开头和结尾的 [ ] 就会消失并再次解析它会起作用：
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
它输出以下内容（以及更多行）
这对我有用，可以给出一个可以放在工作表上的二维数组：
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
我用过link - Parsing JSON to Excel using VBA 解决我的问题，但没有完全解决。 最多 JSON 解析它按预期工作然后无法将其转换为二维数组 & 这就是为什么无法将 JSON 数据转换为 Excel table.
使用如下代码，
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
我的JSON数据如下，
{
"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\"}]"
}
错误： 1] 在本地机器上我在 JSON.toArray 中收到错误，即无法创建二维数组。 2] 当根据 URL 将上述代码与在线 JSON 数据一起使用时，只得到 2 列数据，这是不正确的。
更新代码
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
注意：我已经用多行 JSON
更新了 API错误： 1] 现在我正在获取所需的数据。 2] 但主要问题是，它只出现在 2 行中（1 列用于 header 列，另一行用于数据） 3] 要求是，它应该显示 5 个不同的行，第一行 header
请帮我解决这个问题。
您遇到的第一个问题是您在 JSON 周围放置了一个额外的 { "EmployeeDetails" …json… }，而这个
sJSONString = "{ ""EmployeeDetails"": " + .responseText + "}"
不要那样做！
您遇到的第二个问题是您在 JSON:
中有一个编码为 JSON 的字符串所以你原来的JSON是：
{
"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\"}]"
}
你从 vJSON.Item("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"
}
]
您需要再次解析，因为这仍然是 JSON!
但是您使用的转换器不接受 JSON 以 [ 开头，这是另一个问题。因为如果我去掉括号，那么开头和结尾的 [ ] 就会消失并再次解析它会起作用：
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
它输出以下内容（以及更多行）
这对我有用，可以给出一个可以放在工作表上的二维数组：
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