I have used link -

CodePudding user response：

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 incomplete)
    '  Assumes all field names are unique per record, and no nested objects/arrays
    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