我正在创建的Excel程序中有问题。简而言之，我必须从网站提取JSON数据，进行解析，然后将响应放入工作表中，以备后用。每当代码到达要输出响应文本的位置时，输出就会传递响应文本中我需要的第一组数据。下面的所有数据和示例。
创建并发送HTTP请求的代码：
For i = 1 To 100
URL = "REDACTED"
Set httpRequest = CreateObject("MSXML2.XMLHTTP")
httpRequest.Open "GET", URL, False
httpRequest.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
httpRequest.send ""
Set Output = parse(httpRequest.responseText)
Pallet_Inv.Cells(1 + i, d) = Output.Item("result").Item("contains").Item(i).Item("resourceLabel")
Next
Pallet_Inv是响应文本需要输出到的工作表。 “（1 + i，d）”在那里，因为我在工作表上有一个标题，输出的内容是我不想覆盖的。
解析从请求返回的响应文本的代码：
Public Function parse(ByRef str As String) As Object
Dim Index As Long
Index = 1
psErrors = ""
On Error Resume Next
Call skipChar(str, Index)
Select Case Mid(str, Index, 1)
Case "{"
Set parse = parseObject(str, Index)
Case "["
Set parse = parseArray(str, Index)
Case Else
psErrors = "Invalid JSON"
End Select
End Function
' skip special character
'
Private Sub skipChar(ByRef str As String, ByRef Index As Long)
Dim bComment As Boolean
Dim bStartComment As Boolean
Dim bLongComment As Boolean
Do While Index > 0 And Index <= Len(str)
Select Case Mid(str, Index, 1)
Case vbCr, vbLf
If Not bLongComment Then
bStartComment = False
bComment = False
End If
Case vbTab, " ", "(", ")"
Case "/"
If Not bLongComment Then
If bStartComment Then
bStartComment = False
bComment = True
Else
bStartComment = True
bComment = False
bLongComment = False
End If
Else
If bStartComment Then
bLongComment = False
bStartComment = False
bComment = False
End If
End If
Case "*"
If bStartComment Then
bStartComment = False
bComment = True
bLongComment = True
Else
bStartComment = True
End If
Case Else
If Not bComment Then
Exit Do
End If
End Select
Index = Index + 1
Loop
End Sub
'
' parse collection of key/value
'
Private Function parseObject(ByRef str As String, ByRef Index As Long) As Dictionary
Set parseObject = New Dictionary
Dim sKey As String
' "{"
Call skipChar(str, Index)
If Mid(str, Index, 1) <> "{" Then
psErrors = psErrors & "Invalid Object at position " & Index & " : " & Mid(str, Index) & vbCrLf
Exit Function
End If
Index = Index + 1
Do
Call skipChar(str, Index)
If "}" = Mid(str, Index, 1) Then
Index = Index + 1
Exit Do
ElseIf "," = Mid(str, Index, 1) Then
Index = Index + 1
Call skipChar(str, Index)
ElseIf Index > Len(str) Then
psErrors = psErrors & "Missing '}': " & Right(str, 20) & vbCrLf
Exit Do
End If
' add key/value pair
sKey = parseKey(str, Index)
On Error Resume Next
parseObject.Add sKey, parseValue(str, Index)
If Err.Number <> 0 Then
psErrors = psErrors & Err.Description & ": " & sKey & vbCrLf
Exit Do
End If
Loop
eh:
End Function
Private Function parseKey(ByRef str As String, ByRef Index As Long) As String
Dim dquote As Boolean
Dim squote As Boolean
Dim Char As String
Call skipChar(str, Index)
Do While Index > 0 And Index <= Len(str)
Char = Mid(str, Index, 1)
Select Case (Char)
Case """"
dquote = Not dquote
Index = Index + 1
If Not dquote Then
Call skipChar(str, Index)
If Mid(str, Index, 1) <> ":" Then
psErrors = psErrors & "Invalid Key at position " & Index & " : " & parseKey & vbCrLf
Exit Do
End If
End If
Case "'"
squote = Not squote
Index = Index + 1
If Not squote Then
Call skipChar(str, Index)
If Mid(str, Index, 1) <> ":" Then
psErrors = psErrors & "Invalid Key at position " & Index & " : " & parseKey & vbCrLf
Exit Do
End If
End If
Case ":"
Index = Index + 1
If Not dquote And Not squote Then
Exit Do
Else
parseKey = parseKey & Char
End If
Case Else
If InStr(vbCrLf & vbCr & vbLf & vbTab & " ", Char) Then
Else
parseKey = parseKey & Char
End If
Index = Index + 1
End Select
Loop
End Function
'
' parse string / number / object / array / true / false / null
'
Private Function parseValue(ByRef str As String, ByRef Index As Long)
Call skipChar(str, Index)
Select Case Mid(str, Index, 1)
Case "{"
Set parseValue = parseObject(str, Index)
Case "["
Set parseValue = parseArray(str, Index)
Case """", "'"
parseValue = parseString(str, Index)
Case "t", "f"
parseValue = parseBoolean(str, Index)
Case "n"
parseValue = parseNull(str, Index)
Case Else
parseValue = parseNumber(str, Index)
End Select
End Function
'
' parse list
'
Private Function parseArray(ByRef str As String, ByRef Index As Long) As Collection
Set parseArray = New Collection
' "["
Call skipChar(str, Index)
If Mid(str, Index, 1) <> "[" Then
psErrors = psErrors & "Invalid Array at position " & Index & " : " + Mid(str, Index, 20) & vbCrLf
Exit Function
End If
Index = Index + 1
Do
Call skipChar(str, Index)
If "]" = Mid(str, Index, 1) Then
Index = Index + 1
Exit Do
ElseIf "," = Mid(str, Index, 1) Then
Index = Index + 1
Call skipChar(str, Index)
ElseIf Index > Len(str) Then
psErrors = psErrors & "Missing ']': " & Right(str, 20) & vbCrLf
Exit Do
End If
' add value
On Error Resume Next
parseArray.Add parseValue(str, Index)
If Err.Number <> 0 Then
psErrors = psErrors & Err.Description & ": " & Mid(str, Index, 20) & vbCrLf
Exit Do
End If
Loop
End Function
'
' parse number
'
Private Function parseNumber(ByRef str As String, ByRef Index As Long)
Dim Value As String
Dim Char As String
Call skipChar(str, Index)
Do While Index > 0 And Index <= Len(str)
Char = Mid(str, Index, 1)
If InStr("+-0123456789.eE", Char) Then
Value = Value & Char
Index = Index + 1
Else
parseNumber = CDec(Value)
Exit Function
End If
Loop
End Function
'
' parse string
'
Private Function parseString(ByRef str As String, ByRef Index As Long) As String
Dim quote As String
Dim Char As String
Dim Code As String
Dim SB As New cStringBuilder
Call skipChar(str, Index)
quote = Mid(str, Index, 1)
Index = Index + 1
Do While Index > 0 And Index <= Len(str)
Char = Mid(str, Index, 1)
Select Case (Char)
Case "\"
Index = Index + 1
Char = Mid(str, Index, 1)
Select Case (Char)
Case """", "\", "/", "'"
SB.Append Char
Index = Index + 1
Case "b"
SB.Append vbBack
Index = Index + 1
Case "f"
SB.Append vbFormFeed
Index = Index + 1
Case "n"
SB.Append vbLf
Index = Index + 1
Case "r"
SB.Append vbCr
Index = Index + 1
Case "t"
SB.Append vbTab
Index = Index + 1
Case "u"
Index = Index + 1
Code = Mid(str, Index, 4)
SB.Append ChrW(Val("&h" + Code))
Index = Index + 4
End Select
Case quote
Index = Index + 1
parseString = SB.toString
Set SB = Nothing
Exit Function
Case Else
SB.Append Char
Index = Index + 1
End Select
Loop
parseString = SB.toString
Set SB = Nothing
End Function
该网站的原始JSON数据：
{"result":{"contains":[{"cptInMillis":1547531880000,"containerType":"Case
","cpt":"REDACTED
PM","stackingFilter":"REDACTED","associationReason":"-","isEmpty":"-","resourceLabel":"csXP25jMSzG","associatedUser":"REDACTED","cleanupAllowed":false,"isClosed":"-","containerId":"REDACTED","isForcedMove":"No","dwellTime":"REDACTED
: 1"},{"cptInMillis":1547531880000,"containerType":"Case
","cpt":"REDACTED
PM","stackingFilter":"REDACTED","associationReason":"-","isEmpty":"-","resourceLabel":"csXP25jMTHk","associatedUser":"REDACTED","cleanupAllowed":false,"isClosed":"-","containerId":"REDACTED","isForcedMove":"No","dwellTime":"REDACTED
: 2"},{"cptInMillis":1547531880000,"containerType":"Case
","cpt":"REDACTED
PM","stackingFilter":"REDACTED","associationReason":"-","isEmpty":"-","resourceLabel":"csXP25jMTN5","associatedUser":"REDACTED","cleanupAllowed":false,"isClosed":"-","containerId":"REDACTED","isForcedMove":"No","dwellTime":"REDACTED
: 2"},{"cptInMillis":1547445480000,"containerType":"Case
","cpt":"REDACTED
PM","stackingFilter":"REDACTED","associationReason":"-","isEmpty":"-","resourceLabel":"csXP25k9Z5F","associatedUser":"REDACTED","cleanupAllowed":false,"isClosed":"-","containerId":"REDACTED","isForcedMove":"No","dwellTime":"REDACTED
: 2"}],"endToken":null,"startToken":"0"},"ok":true,"message":""}
现在，由于某些数据是机密信息，因此我已对其进行了删节，但是我实际需要的东西却留在原地。
我需要在这里添加的JSON数据中存在的“ resourceLabel”对象。
现在我确实获取了数据，但是它开始在第二个“ resourceLabel”对象而不是第一个对象上输出。
我需要什么：
csXP25jMSzG csXP25jMTHk csXP25jMTN5 csXP25k9Z5F
我不断得到的东西：
csXP25jMTHk
csXP25jMTN5
csXP25k9Z5F
现在我可能会遗漏一些显而易见的东西，但是我不确定为什么这种情况一直在发生。如果这个问题太复杂，太长或解释不充分，请告诉我。或者，如果Stack不是解决此类问题的正确位置，请将我带往其他地方。
任何帮助将不胜感激。 谢谢。
答案 0 :(得分：2)
除非您的主要目标是编写JSON解析器，否则建议使用现有的JSON转换器。我一直在使用GitHub中的那个。使用该转换器，获得resourceLabel相对容易。这是一种方法：
Option Explicit
Sub pj()
Dim strJSON As String
Dim JSON As Dictionary
Dim dRES As Dictionary
Dim oContains As Collection
Dim V
strJSON = Cells(1, 1).Value2
Set JSON = parsejson(strJSON)
Set dRES = JSON("result")
Set oContains = dRES("contains")
For Each V In oContains
Debug.Print V("resourceLabel")
Next V
End Sub
使用A1中的JSON字符串，输出：
csXP25jMSzG
csXP25jMTHk
csXP25jMTN5
csXP25k9Z5F