Parse Large amount of Json in Excel - json

Question

I have an application which reads in files containing json data parses them then performs some formatting and calculations.
The Core of the code itself works fine, however the issue I have is that it is slow.
I got Json Parsing code from another site (not sure if i'm allowed to link to it), and what I do is I split the file from the data into an array, Parse each row and put it into another array then perform all my tasks later.
The slow part is the Parsing of the data, overall it's pretty quick and works through about 10-15 rows a second, however my files have upwards of 5k rows of data in them, meaning each file takes roughly 5 minutes, and when as there are hundreds of files to get through, it takes almost an entire day to full parse all the data.
I've attached snippets of my code (not the full parsing functions as that's really long) just to give an idea of how my code is currently working
My query is, is there a way I can parse the entire file (each record is seperated by a line feed) instead of having to parse it row by row?
sourceArray = Split(sourceText, vbLf)
For Ctr = LBound(sourceArray) To UBound(sourceArray)
Set dic = ParseJSON(sourceArray(Ctr)
For Each v In dic
(do some formatting stuff, I tested by completely commenting out this part to make sure the ParseJSON is where the slowdown is)
next v
Next Ctr
Json Parser code
'-------------------------------------------------------------------
' VBA JSON Parser
'-------------------------------------------------------------------
Function ParseJSON(json$, Optional key$ = "obj") As Object
p = 1
token = Tokenize(json)
Set dic = CreateObject("Scripting.Dictionary")
If token(p) = "{" Then ParseObj key Else ParseArr key
Set ParseJSON = dic
End Function
Function ParseObj(key$)
Do: p = p + 1
Select Case token(p)
Case "]"
Case "[": ParseArr key
Case "{"
If token(p + 1) = "}" Then
p = p + 1
dic.Add key, "null"
Else
ParseObj key
End If
Case "}": key = ReducePath(key): Exit Do
Case ":": key = key & "." & token(p - 1)
Case ",": key = ReducePath(key)
Case Else: If token(p + 1) <> ":" Then dic.Add key, token(p)
End Select
Loop
End Function
Function ParseArr(key$)
Dim e&
Do: p = p + 1
Select Case token(p)
Case "}"
Case "{": ParseObj key & ArrayID(e)
Case "[": ParseArr key
Case "],": e = e
Case "]": Exit Do
Case ":": key = key & ArrayID(e)
Case ",": e = e + 1
Case Else: dic.Add key & ArrayID(e), token(p)
End Select
Loop
End Function
'-------------------------------------------------------------------
' Support Functions
'-------------------------------------------------------------------
Function Tokenize(s$)
Const Pattern = """(([^""\\]|\\.)*)""|[+\-]?(?:0|[1-9]\d*)(?:\.\d*)?(?:[eE][+\-]?\d+)?|\w+|[^\s""']+?"
Tokenize = RExtract(s, Pattern, True)
End Function
Function RExtract(s$, Pattern, Optional bGroup1Bias As Boolean, Optional bGlobal As Boolean = True)
Dim c&, m, n, v
With CreateObject("vbscript.regexp")
.Global = bGlobal
.MultiLine = False
.IgnoreCase = True
.Pattern = Pattern
If .test(s) Then
Set m = .Execute(s)
ReDim v(1 To m.Count)
For Each n In m
c = c + 1
v(c) = n.Value
If bGroup1Bias Then If Len(n.subMatches(0)) Or n.Value = """""" Then v(c) = n.subMatches(0)
Next
End If
End With
RExtract = v
End Function
Function ArrayID$(e)
ArrayID = "(" & e & ")"
End Function
Function ReducePath$(key$)
If InStr(key, ".") Then ReducePath = Left(key, InStrRev(key, ".") - 1) Else ReducePath = key
End Function
Function ListPaths(dic)
Dim s$, v
For Each v In dic
s = s & v & " --> " & dic(v) & vbLf
Next
End Function
Function GetFilteredValues(dic, Match)
Dim c&, i&, v, w
v = dic.Keys
ReDim w(1 To dic.Count)
For i = 0 To UBound(v)
If v(i) Like Match Then
c = c + 1
w(c) = dic(v(i))
End If
Next
ReDim Preserve w(1 To c)
GetFilteredValues = w
End Function
Function GetFilteredTable(dic, cols)
Dim c&, i&, j&, v, w, z
v = dic.Keys
z = GetFilteredValues(dic, cols(0))
ReDim w(1 To UBound(z), 1 To UBound(cols) + 1)
For j = 1 To UBound(cols) + 1
z = GetFilteredValues(dic, cols(j - 1))
For i = 1 To UBound(z)
w(i, j) = z(i)
Next
Next
GetFilteredTable = w
End Function
Function OpenTextFile$(f)
With CreateObject("ADODB.Stream")
.Charset = "utf-8"
.Open
.LoadFromFile f
OpenTextFile = .ReadText
End With
End Function
Sample Data
{
"op": "mcm",
"clk": "4985835795",
"pt": 1641446989915,
"mc": [
{
"id": "1.193068822",
"rc": [
{
"batl": [
[
0,
85,
10
]
],
"ltp": 0.0,
"tv": 0.0,
"id": 536162
},
{
"batl": [
[
0,
85,
5
]
],
"ltp": 0.0,
"tv": 0.0,
"id": 36024159
},
{
"batb": [
[
0,
1.02,
322
]
],
"ltp": 0.0,
"tv": 0.0,
"id": 22734575
},
{
"batb": [
[
0,
1.02,
322
]
],
"ltp": 0.0,
"tv": 0.0,
"id": 16286497
},
{
"batb": [
[
0,
1.02,
322
]
],
"ltp": 0.0,
"tv": 0.0,
"id": 18673417
},
{
"batl": [
[
0,
85,
10
]
],
"ltp": 0.0,
"tv": 0.0,
"id": 38835846
},
{
"batl": [
[
0,
85,
10
]
],
"ltp": 0.0,
"tv": 0.0,
"id": 1527689
},
{
"batb": [
[
0,
1.02,
322
]
],
"ltp": 0.0,
"tv": 0.0,
"id": 36394575
},
{
"batb": [
[
0,
1.02,
322
]
],
"ltp": 0.0,
"tv": 0.0,
"id": 1276636
}
]
}
]
}

Answer 1

I'm using this library to parse a json file with 4560 objects and 532kb under 3 seconds.
https://github.com/VBA-tools/VBA-JSON
Sub main()
Dim FSO As New FileSystemObject
Dim JsonTS As TextStream
Dim JsonText As String
Dim Parsed As Dictionary
Set JsonTS = FSO.OpenTextFile("sample4.json", ForReading)
JsonText = JsonTS.ReadAll
JsonTS.Close
Set Parsed = JsonConverter.ParseJson(JsonText)
For i = 1 To Parsed("people").Count
With Sheets(1)
Range("A" & i).Value = Parsed("people")(i)("firstName")
Range("B" & i).Value = Parsed("people")(i)("lastName")
Range("C" & i).Value = Parsed("people")(i)("gender")
Range("D" & i).Value = Parsed("people")(i)("age")
Range("E" & i).Value = Parsed("people")(i)("number")
End With
Next
End Sub
{
"people": [
{
"firstName": "Joe",
"lastName": "Jackson",
"gender": "male",
"age": 28,
"number": "7349282382"
}
]
}