Excel VBA: parsing JSON - json

Question

Hope somebody might able to help me.
I am a real rookie in this field, had a friend of mine write up the following code some time ago.
I have VB in Excel that gets data from a yahoo API, URL: "https://query2.finance.yahoo.com/v8/finance/chart/" & ticker & "?interval=1m&range=1d"
The data gets inserted in excel and is auto-refreshed every minute.
Everything works smoothly with no issues.
Now to the challange, since the data gets auto purged after a day in the excel, I would need to extend the amount of data (rows) from the current 1 day to 7 days.
So I tried simply to change the URL from the above mentioned to the following:
"https://query2.finance.yahoo.com/v8/finance/chart/" & ticker & "?interval=1m&range=7d"
However the parsing in the code gives me errors which I am to bad at solving..
First warning comes in the code:
"Case Else: If token(p + 1) <> ":" Then dic.Add key, token(p)"
And the whole code is as below (feel free to try it in excel if you would like), thanks in advance.
Option Explicit
Private p&, token, dic
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 "{": ParseObj 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 "]": 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
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
Debug.Print s
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
Function toUnix(dt) As Long
toUnix = DateDiff("s", "1/1/1970 00:00:00", dt)
End Function
Function fromUnix(ts) As Date
fromUnix = DateAdd("s", ts, "1/1/1970 00:00:00")
End Function
Private Sub GetData()
' Queue next invocation
Application.OnTime Now + TimeValue("00:01:00"), "GetData"
Dim DataSheet As Worksheet
Set DataSheet = Sheets("Data")
Dim ParameterSheet As Worksheet
Set ParameterSheet = Sheets("Parameters")
Dim scrape As String
scrape = ParameterSheet.Range("B2").Value
If scrape <> "TRUE" Then
Exit Sub
End If
Dim ticker As String
ticker = ParameterSheet.Range("A2").Value
Dim url As String
url = "https://query2.finance.yahoo.com/v8/finance/chart/" & ticker & "?interval=1m&range=1d"
Dim hReq As Object
Set hReq = CreateObject("MSXML2.XMLHTTP")
With hReq
.Open "GET", url, False
.Send
End With
Dim json As Object
Set json = ParseJSON(hReq.ResponseText)
Dim closes As Variant
closes = GetFilteredValues(json, "*.close*")
Dim opens As Variant
opens = GetFilteredValues(json, "*.open*")
Dim volumes As Variant
volumes = GetFilteredValues(json, "*.volume*")
Dim highs As Variant
highs = GetFilteredValues(json, "*.high*")
Dim lows As Variant
lows = GetFilteredValues(json, "*.low*")
Dim timestamps As Variant
timestamps = GetFilteredValues(json, "*.timestamp*")
Dim i As Integer
i = UBound(timestamps) + 1
Dim row As Integer
row = 2
' Load new data in
Dim timestamp As Variant
For Each timestamp In timestamps
i = i - 1
timestamp = Int(timestamps(i) / 60) * 60
If "null" = closes(i) Then
GoTo Continue
End If
If DataSheet.Range("H" & row).Value = "" Then
' Empty dataset
ElseIf toUnix(DataSheet.Range("H" & row).Value) < timestamp Then
' There is new data, prepend
DataSheet.Rows(row).Insert
ElseIf toUnix(DataSheet.Range("H" & row).Value) = timestamp Then
' Replace old data,
Else: GoTo Continue
End If
DataSheet.Range("B" & row).Value = ticker
DataSheet.Range("C" & row).Value = opens(i)
DataSheet.Range("D" & row).Value = highs(i)
DataSheet.Range("E" & row).Value = lows(i)
DataSheet.Range("F" & row).Value = closes(i)
DataSheet.Range("G" & row).Value = volumes(i)
DataSheet.Range("H" & row).Value = fromUnix(timestamp)
row = row + 1
Continue:
Next timestamp
' Remove data that is more then 10 days old
row = 1
Do While True
row = row + 1
Dim datee As Variant
datee = DataSheet.Range("H" & row).Value
If datee = "" Then
Exit Do
End If
If toUnix(datee) + 864000 < toUnix(Now()) Then
DataSheet.Rows(row).EntireRow.Delete
row = row - 1 ' This prevents skipping the next line
End If
Loop
End Sub
Private Sub Auto_Open()
GetData
End Sub

Answer 1

Problem is the parsing code cannot deal with the multiple trading periods which in the JSON are arrays within arrays [[{}],[{}],[{}]] when the range is greater than 1 day. The array index counter e is reset at each opening bracket so you get identical keys for each trading period. Dictionary keys must be unique hence the error. The best solution would be to rewrite using a modern parser but as a quick-fix hack the ParseArr function as follows ;
Function ParseArr(key$)
'Dim e& move to top of script
' add this line
If InStr(1, key, "tradingPeriods") = 0 Then e = 0
Do: p = p + 1
' no change to this code
Loop
End Function