如何在VBA中直接从json数据中获取子元素的值

I have seen way where JSON data can be used to print rows in excel/macro. That answer is here - > How to convert JSON data to xml data in excel macro or VB.Net

我已经看到JSON数据可以用于在excel/宏中打印行。答案就在这里——>如何在excel宏或VB.Net中将JSON数据转换为xml数据

But there is another issue, how can i get the value of child element People from json data so that i can get the value of data from it for further use.

但是还有另外一个问题，如何从json数据中获取子元素的值，这样我就可以从它那里得到数据的值以供进一步使用。

The data i am getting is like :

我得到的数据是:

{"properties":{"SuccessCount":1,"PendingCount":0},"People":[{"memberId":"3","memberAge":2,"memberCount":1,"memberName":"Alex"},{"memberId":"4","memberAge":5,"memberCount":1,"memberName":"Peter"},{"memberId":"5","memberAge":2,"memberCount":1,"memberName":"Kirby"}],"TotalMembers":3}

2 个解决方案

#1

This will do the trick:

这将会达到目的:

Public Sub JsonTable2Range(rOut As Range, json As String)
    Dim i&, j&, p1&, p2&, sRow$, cols, v, vp

    p1 = InStr(json, "[")
    p2 = InStr(json, "]")
    If p1 And p2 Then
        json = Mid$(json, p1, p2 - p1 + 1)
    End If

    i = 1
    p1 = 1
    Do
        p1 = InStr(p1, json, "{"): If p1 = 0 Then Exit Do
        p2 = InStr(p1, json, "}")
        sRow = Mid$(json, p1 + 1, p2 - p1 - 1)
        cols = Split(sRow, ",")
        If i = 1 Then
            ReDim v(0 To UBound(Split(json, "}")) + 1, 0 To UBound(cols) + 1)
            For j = 0 To UBound(cols)
                vp = Split(cols(j), ":")
                v(0, j) = ProcessValuePair(vp, 0)
            Next
        End If
        For j = 0 To UBound(cols)
            vp = Split(cols(j), ":")
            v(i, j) = ProcessValuePair(vp, 1)
        Next
        i = i + 1
        p1 = p1 + 1
    DoEvents
    Loop
    If i > 1 Then rOut.Resize(UBound(v), UBound(v, 2)) = v
End Sub

Private Function ProcessValuePair(vp, n)
    If Asc(Mid$(vp(n), 1, 1)) = 10 Then vp(n) = Mid$(vp(n), 2)
    vp(n) = Trim$(vp(n))
    If Left$(vp(n), 1) = "'" Or Left$(vp(n), 1) = """" Or Left$(vp(n), 1) = "\" Then
        vp(n) = Mid$(vp(n), 2, Len(vp(n)) - 2)
        If Left$(vp(n), 1) = """" And Right$(vp(n), 1) = "\" Then
            vp(n) = Mid$(vp(n), 2, Len(vp(n)) - 2)
        End If
    Else
        vp(n) = Val(vp(n))
    End If
    ProcessValuePair = vp(n)
End Function

#2

Consider this example:

考虑一下这个例子:

Option Explicit

Sub JsonPopulateCellsTest()
    Dim strJsonString As String
    Dim varJson As Variant
    Dim strState As String
    Dim varPeople() As Variant
    Dim i As Long
    Dim y As Long

    ' parse JSON string
    strJsonString = "{""properties"":{""SuccessCount"":1,""PendingCount"":0},""People"":[{""memberId"":""3"",""memberAge"":2,""memberCount"":1,""memberName"":""Alex""},{""memberId"":""4"",""memberAge"":5,""memberCount"":1,""memberName"":""Peter""},{""memberId"":""5"",""memberAge"":2,""memberCount"":1,""memberName"":""Kirby""}],""TotalMembers"":3}"
    ParseJson strJsonString, varJson, strState
    If strState = "Error" Then
        MsgBox "Error"
        Exit Sub
    End If

    ' show the full structure starting from root element
    MsgBox BeautifyJson(varJson)

    ' retrieve People array
    varPeople = varJson("People")

    ' show the structure of People array
    MsgBox BeautifyJson(varPeople)


    y = 1 ' begin row

    ' output
    For i = 0 To UBound(varPeople)
        Cells(y + i, 1).Value = varPeople(i)("memberId")
        Cells(y + i, 2).Value = varPeople(i)("memberAge")
        Cells(y + i, 3).Value = varPeople(i)("memberCount")
        Cells(y + i, 4).Value = varPeople(i)("memberName")
    Next

End Sub

Sub ParseJson(ByVal strContent As String, varJson As Variant, strState As String)
    ' strContent - source JSON string
    ' varJson - created object or array to be returned as result
    ' strState - Object|Array|Error depending on processing to be returned as state
    Dim objTokens As Object
    Dim lngTokenId As Long
    Dim objRegEx As Object
    Dim bMatched As Boolean

    Set objTokens = CreateObject("Scripting.Dictionary")
    lngTokenId = 0
    Set objRegEx = CreateObject("VBScript.RegExp")
    With objRegEx
        ' specification http://www.json.org/
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = """(?:\\""|[^""])*""(?=\s*(?:,|\:|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "str"
        .Pattern = "(?:[+-])?(?:\d+\.\d*|\.\d+|\d+)e(?:[+-])?\d+(?=\s*(?:,|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "num"
        .Pattern = "(?:[+-])?(?:\d+\.\d*|\.\d+|\d+)(?=\s*(?:,|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "num"
        .Pattern = "\b(?:true|false|null)(?=\s*(?:,|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "cst"
        .Pattern = "\b[A-Za-z_]\w*(?=\s*\:)" ' unspecified name without quotes
        Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "nam"
        .Pattern = "\s"
        strContent = .Replace(strContent, "")
        .MultiLine = False
        Do
            bMatched = False
            .Pattern = "<\d+(?:str|nam)>\:<\d+(?:str|num|obj|arr|cst)>"
            Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "prp"
            .Pattern = "\{(?:<\d+prp>(?:,<\d+prp>)*)?\}"
            Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "obj"
            .Pattern = "\[(?:<\d+(?:str|num|obj|arr|cst)>(?:,<\d+(?:str|num|obj|arr|cst)>)*)?\]"
            Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "arr"
        Loop While bMatched
        .Pattern = "^<\d+(?:obj|arr)>$" ' unspecified top level array
        If Not (.test(strContent) And objTokens.Exists(strContent)) Then
            varJson = Null
            strState = "Error"
        Else
            Retrieve objTokens, objRegEx, strContent, varJson
            strState = IIf(IsObject(varJson), "Object", "Array")
        End If
    End With
End Sub

Sub Tokenize(objTokens, objRegEx, strContent, lngTokenId, bMatched, strType)
    Dim strKey As String
    Dim strRes As String
    Dim lngCopyIndex As Long
    Dim objMatch As Object

    strRes = ""
    lngCopyIndex = 1
    With objRegEx
        For Each objMatch In .Execute(strContent)
            strKey = "<" & lngTokenId & strType & ">"
            bMatched = True
            With objMatch
                objTokens(strKey) = .Value
                strRes = strRes & Mid(strContent, lngCopyIndex, .FirstIndex - lngCopyIndex + 1) & strKey
                lngCopyIndex = .FirstIndex + .Length + 1
            End With
            lngTokenId = lngTokenId + 1
        Next
        strContent = strRes & Mid(strContent, lngCopyIndex, Len(strContent) - lngCopyIndex + 1)
    End With
End Sub

Sub Retrieve(objTokens, objRegEx, strTokenKey, varTransfer)
    Dim strContent As String
    Dim strType As String
    Dim objMatches As Object
    Dim objMatch As Object
    Dim strName As String
    Dim varValue As Variant
    Dim objArrayElts As Object

    strType = Left(Right(strTokenKey, 4), 3)
    strContent = objTokens(strTokenKey)
    With objRegEx
        .Global = True
        Select Case strType
            Case "obj"
                .Pattern = "<\d+\w{3}>"
                Set objMatches = .Execute(strContent)
                Set varTransfer = CreateObject("Scripting.Dictionary")
                For Each objMatch In objMatches
                    Retrieve objTokens, objRegEx, objMatch.Value, varTransfer
                Next
            Case "prp"
                .Pattern = "<\d+\w{3}>"
                Set objMatches = .Execute(strContent)

                Retrieve objTokens, objRegEx, objMatches(0).Value, strName
                Retrieve objTokens, objRegEx, objMatches(1).Value, varValue
                If IsObject(varValue) Then
                    Set varTransfer(strName) = varValue
                Else
                    varTransfer(strName) = varValue
                End If
            Case "arr"
                .Pattern = "<\d+\w{3}>"
                Set objMatches = .Execute(strContent)
                Set objArrayElts = CreateObject("Scripting.Dictionary")
                For Each objMatch In objMatches
                    Retrieve objTokens, objRegEx, objMatch.Value, varValue
                    If IsObject(varValue) Then
                        Set objArrayElts(objArrayElts.Count) = varValue
                    Else
                        objArrayElts(objArrayElts.Count) = varValue
                    End If
                    varTransfer = objArrayElts.Items
                Next
            Case "nam"
                varTransfer = strContent
            Case "str"
                varTransfer = Mid(strContent, 2, Len(strContent) - 2)
                varTransfer = Replace(varTransfer, "\""", """")
                varTransfer = Replace(varTransfer, "\\", "\")
                varTransfer = Replace(varTransfer, "\/", "/")
                varTransfer = Replace(varTransfer, "\b", Chr(8))
                varTransfer = Replace(varTransfer, "\f", Chr(12))
                varTransfer = Replace(varTransfer, "\n", vbLf)
                varTransfer = Replace(varTransfer, "\r", vbCr)
                varTransfer = Replace(varTransfer, "\t", vbTab)
                .Global = False
                .Pattern = "\\u[0-9a-fA-F]{4}"
                Do While .test(varTransfer)
                    varTransfer = .Replace(varTransfer, ChrW(("&H" & Right(.Execute(varTransfer)(0).Value, 4)) * 1))
                Loop
            Case "num"
                varTransfer = Evaluate(strContent)
            Case "cst"
                Select Case LCase(strContent)
                    Case "true"
                        varTransfer = True
                    Case "false"
                        varTransfer = False
                    Case "null"
                        varTransfer = Null
                End Select
        End Select
    End With
End Sub

Function BeautifyJson(varJson As Variant) As String
    Dim strResult As String
    Dim lngIndent As Long
    BeautifyJson = ""
    lngIndent = 0
    BeautyTraverse BeautifyJson, lngIndent, varJson, vbTab, 1
End Function

Sub BeautyTraverse(strResult As String, lngIndent As Long, varElement As Variant, strIndent As String, lngStep As Long)
    Dim arrKeys() As Variant
    Dim lngIndex As Long
    Dim strTemp As String

    Select Case VarType(varElement)
        Case vbObject
            If varElement.Count = 0 Then
                strResult = strResult & "{}"
            Else
                strResult = strResult & "{" & vbCrLf
                lngIndent = lngIndent + lngStep
                arrKeys = varElement.Keys
                For lngIndex = 0 To UBound(arrKeys)
                    strResult = strResult & String(lngIndent, strIndent) & """" & arrKeys(lngIndex) & """" & ": "
                    BeautyTraverse strResult, lngIndent, varElement(arrKeys(lngIndex)), strIndent, lngStep
                    If Not (lngIndex = UBound(arrKeys)) Then strResult = strResult & ","
                    strResult = strResult & vbCrLf
                Next
                lngIndent = lngIndent - lngStep
                strResult = strResult & String(lngIndent, strIndent) & "}"
            End If
        Case Is >= vbArray
            If UBound(varElement) = -1 Then
                strResult = strResult & "[]"
            Else
                strResult = strResult & "[" & vbCrLf
                lngIndent = lngIndent + lngStep
                For lngIndex = 0 To UBound(varElement)
                    strResult = strResult & String(lngIndent, strIndent)
                    BeautyTraverse strResult, lngIndent, varElement(lngIndex), strIndent, lngStep
                    If Not (lngIndex = UBound(varElement)) Then strResult = strResult & ","
                    strResult = strResult & vbCrLf
                Next
                lngIndent = lngIndent - lngStep
                strResult = strResult & String(lngIndent, strIndent) & "]"
            End If
        Case vbInteger, vbLong, vbSingle, vbDouble
            strResult = strResult & varElement
        Case vbNull
            strResult = strResult & "Null"
        Case vbBoolean
            strResult = strResult & IIf(varElement, "True", "False")
        Case Else
            strTemp = Replace(varElement, "\""", """")
            strTemp = Replace(strTemp, "\", "\\")
            strTemp = Replace(strTemp, "/", "\/")
            strTemp = Replace(strTemp, Chr(8), "\b")
            strTemp = Replace(strTemp, Chr(12), "\f")
            strTemp = Replace(strTemp, vbLf, "\n")
            strTemp = Replace(strTemp, vbCr, "\r")
            strTemp = Replace(strTemp, vbTab, "\t")
            strResult = strResult & """" & strTemp & """"
    End Select

End Sub