Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Fetches historical stock prices from Yahoo using the https://query1.finance.yahoo.com/v7/finance/chart/ interface
' Written by Andrew MacLean Nov 20th 2017 Version 1.0d updates at http://www.signalsolver.com/EmulateURL.
' Questions, Comments, Requests?, please contact support@algorithmscience.com
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub GetYahooDataFromJSON()
Dim DesiredFields As Variant, NameOfStock As String
Dim RangeField As String, RangeUnit As String, s As Variant, IntervalField As String, DateOrder As Integer
Dim DateOffset As Double, ErrorMsg As String, FilterFilterOutRows As Boolean
Dim BeginDate As Date, EndDate As Date
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False
With ActiveSheet
'READ THE STOCK SYMBOL:
NameOfStock = .Range("StockSymbol")
'READ THE RANGE
RangeField = CStr(.Range("Range"))
'READ AND TRANSLATE THE RANGE UNIT
s = CStr(.Range("RangeUnit"))
Select Case s:
Case "Maximum": RangeUnit = "max": RangeField = ""
Case "YTD": RangeUnit = "ytd": RangeField = ""
Case "Years": RangeUnit = "y"
Case "Months": RangeUnit = "mo"
Case "Weeks": RangeUnit = "wk"
Case "Days": RangeUnit = "d"
Case "Hours": RangeUnit = "h"
Case "Minutes": RangeUnit = "m"
End Select
RangeField = RangeField & RangeUnit
'READ AND TRANSLATE THE INTERVAL FIELD
s = CStr(.Range("Interval"))
Select Case s:
Case "1 minute": IntervalField = "1m"
Case "2 minutes": IntervalField = "2m"
Case "5 minutes": IntervalField = "5m"
Case "10 minutes": IntervalField = "10m"
Case "15 minutes": IntervalField = "15m"
Case "30 minutes": IntervalField = "30m"
Case "1 hour": IntervalField = "1h"
Case "2 hour": IntervalField = "2h"
Case "4 hour": IntervalField = "4h"
Case "6 hour": IntervalField = "6h"
Case "1 day": IntervalField = "1d"
Case "1 week": IntervalField = "1wk"
Case "1 month": IntervalField = "1mo"
Case "3 months": IntervalField = "3mo"
End Select
'READ THE DATE ORDER
s = CStr(.Range("DateOrder"))
If s = "Ascending" Then DateOrder = xlAscending Else DateOrder = xlDescending
'READ THE TIME OFFSET:
DateOffset = CDbl(.Range("TimeOffset"))
'FILTER BAD ROWS?
If (.Range("FilterBadRows")) = "Yes" Then FilterFilterOutRows = True Else FilterFilterOutRows = False
'START AND END DATE:
BeginDate = .Range("StartingDate"): EndDate = .Range("EndingDate")
'SINCE WE HAVE A START DATE AND END DATE, THE RANGE CAN GET A BIT COMPLICATED, WE WILL ADDRESS THAT IN A LATER RELEASE
'FOR NOW JUST MAKE SURE YOUR RANGE COVERS THE START AND END DATE
'YOU CAN ADD OR REMOVE AS MANY JSON FIELDS YOU LIKE HERE, OR RE-ORDER THEM:
DesiredFields = Array("timestamp", "open", "high", "low", "close", "volume")
'1.0d YOU CAN ASK FOR adjclose IF IntervalField IS 1d, 1w, 1mo or 3mo.
If Right(IntervalField, 1) <> "m" And Right(IntervalField, 1) <> "h" Then
DesiredFields = Array("timestamp", "open", "high", "low", "close", "adjclose", "volume")
End If
'CHANGE THE BUTTON COLOR AND TEXT:
.Shapes("Shape1").Fill.ForeColor.RGB = RGB(0, 200, 0)
.Shapes("Shape1").TextFrame.Characters.Text = "Asking for data..."
Application.ScreenUpdating = True 'JUST ENSURES UPDATE OF THE BUTTON
'GET THE DATA. IF YOU WANT THE DATA IN A DIFFERENT PLACE, CHANGE THE .Range("TableOrigin") TO SOMETHING ELSE E.G. Sheet2.Range("A1")
ErrorMsg = GetYahooRequest(.Range("TableOrigin"), DesiredFields, NameOfStock, RangeField, _
IntervalField, DateOrder, DateOffset, FilterFilterOutRows, BeginDate, EndDate)
If ErrorMsg <> "" Then MsgBox (ErrorMsg)
'CHANGE THE BUTTON BACK
.Shapes("Shape1").Fill.ForeColor.RGB = RGB(200, 0, 0)
.Shapes("Shape1").TextFrame.Characters.Text = "Click to get historic data"
Application.ScreenUpdating = True 'JUST ENSURES UPDATE OF THE BUTTON
End With 'ActiveSheet
Range("A2", Range("A2").End(xlDown).End(xlToRight)).Copy
End Sub
Function GetYahooRequest( _
DestinationRange As Range, _
FieldsToExtract As Variant, _
StockSymbol As String, _
RangePart As String, _
IntervalPart As String, _
Optional DateOrder As Integer = xlDescending, _
Optional TOffset As Double = 0, _
Optional FilterBadPrices As Boolean = False, _
Optional StartingDate As Date = 0, _
Optional EndingDate As Date = 0 _
) As String
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'FETCHES HISTORICAL STOCK PRICES FROM YAHOO FINANCE USING THE query1.finance.yahoo.com/v7/finance/chart INTERFACE
'WRITES THE PARSED JSON DATA TO A WORKSHEET AFTER CLEARING THE CONTENTS OF THE REGION
'RETURNS AN EMPTY STRING IF NO ERROR DETECTED, OTHERWISE RETURNS A POSSIBLY MEANINGFUL ERROR MESSAGE
'
'ARGUMENTS:
'DestinationRange As Range, THE TOP LEFTMOST CELL OF THE TABLE WHERE THE DATA SHOULD BE PUT E.G. Sheet1.Range("A20")
'FieldsToExtract As Variant, AN ARRAY OF JSON KEYS E.G. = Array("timestamp", "open", "high", "low", "close", "volume")
'StockSymbol As String: THE STOCK SYMBOL, E.G. AAPL, BP.L, ^GDAXI
'RangePart As String: THE OVERALL TIME RANGE OF THE DATA: CAN BE max, ytd, Xy, Xm, Xd, Xh, Xm WHERE X IS AN INTEGER, E.G. "50d"
'IntervalPart As String: THE TIME INTERVAL OF EACH DATA BAR: 1m, 2m, 5m, 15m, 1h, 1d, 1mo, 3mo
'OPTIONAL:
'DateOrder As Integer: CAN ONLY BE xlAscending OR xlDescending. DEFAULT IS DESCENDING
'TOffest As Double: A NUMBER REPRESENTING A TIME OFFSET IN HOURS. DATES WILL BE OFFSET BY THIS AMOUNT FROM GMT. CAN BE NEGATIVE, DEFAULT 0
'FilterBadPrices As Boolean: IF True, REMOVES ALL LINES WITH "nulls" OR ZEROS IN THE PRICES. DEFAULT IS False
'StartingDate as Date: ANY ROW WITH A TIMESTAMP + TOffset (i.e LOCAL TIME) BEFORE THIS DATE WILL BE FILTERED OUT. ZERO STOPS FILTERING
'EndingDate as Date: ANY ROW WITH A TIMESTAMP + TOffset (i.e LOCAL TIME) AFTER THIS DATE WILL BE FILTERED OUT. ZERO STOPS FILTERING
'
' WRITTEN BY Andrew MacLean Oct 9th 2017 Version 1.0d updates at http://www.signalsolver.com.
' Questions, Comments, Requests?, please contact support@algorithmscience.com
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False
On Error GoTo ErrorHandler
Dim strUrl As String
strUrl = "https://query1.finance.yahoo.com/v7/finance/chart/" & StockSymbol & "?range=" & RangePart & "&interval=" & IntervalPart & "&indicators=quote&includeTimestamps=true"
'IF THE COMPILER DOESN'T RECOGNIZE WinHttp, SIMPLY MAKE SURE THAT "Microsoft WinHTTP Services" ARE ENABLED UNDER VBA TOOLS->REFERENCES
Dim objRequest As WinHttp.WinHttpRequest
Dim strResponse As String
Dim N() As String
Dim RawOutputArray() As Variant, FilteredOutputArray() As Variant
Dim FilterOutRows() As Variant, FilteredRowCount As Integer: FilteredRowCount = 0
Dim FieldName As Variant
Dim xRow As Integer: xRow = 0
Dim RowCount As Integer, ColumnCount As Integer
Dim xColumn As Integer
Dim StrX As String
Dim ParseError As String
Dim DecSeparator As String: DecSeparator = Application.International(xlDecimalSeparator)
Dim FilterOutput As Boolean
'FILTER LOGIC:
If FilterBadPrices = True Or StartingDate <> 0 Or EndingDate <> 0 Then FilterOutput = True
Set objRequest = New WinHttp.WinHttpRequest
With objRequest
.Open "GET", strUrl, True
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
.send
.waitForResponse
strResponse = .responseText
End With
'UNCOMMENT THIS LINE IF YOU WOULD LIKE TO EXAMINE THE JSON CODE (SET THE DESTINATION RANGE):
'N = Split(strResponse, ","): ActiveSheet.Range("J1").Resize(UBound(N) + 1) = WorksheetFunction.Transpose(N)
'BEST TO CLEAR THE REGION BEFORE WRITING TO IT
DestinationRange.CurrentRegion.ClearContents
For Each FieldName In FieldsToExtract
'LOOK FOR DATA AND WRITE IT TO HoldArray String ARRAY IF WE FIND IT:
Dim HoldArray() As String
ParseError = ParseField(strResponse, CStr(FieldName), HoldArray)
If ParseError <> "" Then GoTo ErrorHandler
'RESIZE A VARIANT ARRAY TO HOLD THE RESULT.
'THIS GIVES US BETTER CONTROL OF THE STRING CONVERSIONS
If xColumn = 0 Then
RowCount = UBound(HoldArray) + 1
ColumnCount = UBound(FieldsToExtract) + 1
ReDim RawOutputArray(RowCount, ColumnCount - 1)
'WE WILL LATER OPTIONALLY FILTER OUT ROWS INTO THE FINAL OUTPUT ARRAY, THIS ARRAY TRACKS THEM
ReDim FilterOutRows(RowCount)
ReDim DateFilter(RowCount)
'1.0c INITIALIZE FilterOutRows
For xRow = 1 To RowCount: FilterOutRows(xRow) = False: Next xRow
End If
'THIS WRITES THE HEADER FOR THE FIELD OF INTEREST:
RawOutputArray(0, xColumn) = StrConv(FieldName, vbProperCase)
'CONVERT EACH STRING INTO A VARIANT IN THE RawOutputArray:
For xRow = 1 To RowCount
StrX = HoldArray(xRow - 1)
Select Case FieldName
Case "timestamp":
Dim LocalDate As Date
If IsNumeric(StrX) Then 'CONVERT IT '1.0c ADDED
LocalDate = CDate(StrX / 86400) + 25569 + (TOffset / 24)
RawOutputArray(xRow, xColumn) = LocalDate
'1.0c DATE FILTERING LOGIC
If StartingDate <> 0 Then If LocalDate <= StartingDate Then FilterOutRows(xRow) = True
If EndingDate <> 0 Then If LocalDate >= EndingDate Then FilterOutRows(xRow) = True
Else 'NOT NUMERIC: LEAVE IT AS A STRING AND TAG IT TO BE FILTERED OUT
RawOutputArray(xRow, xColumn) = StrX
FilterOutRows(xRow) = True
End If
Case Else:
If IsNumeric(StrX) Then 'CONVERT IT
RawOutputArray(xRow, xColumn) = CDbl(Replace(StrX, ".", DecSeparator))
'TAG THE ROW IF ZERO PRICE:
If FieldName <> "volume" And RawOutputArray(xRow, xColumn) = 0 Then FilterOutRows(xRow) = True
Else 'NOT NUMERIC: LEAVE IT AS A STRING AND TAG IT TO FILTER OUT
RawOutputArray(xRow, xColumn) = (HoldArray(xRow - 1))
FilterOutRows(xRow) = True
End If
End Select 'Fieldname
Next xRow
'MOVE ONTO THE NEXT COLUMN:
xColumn = xColumn + 1
Next
'COUNT THE ROWS TO FILTER OUT:
For xRow = 1 To RowCount
If FilterOutRows(xRow) = True Then FilteredRowCount = FilteredRowCount + 1
Next xRow
'FOR THE CURIOUS:
'If FilteredRowCount > 0 Then MsgBox FilteredRowCount & " Filtered Rows."
'IF WE DON'T NEED TO FILTER THE RESULT, WRITE IT OUT TO THE SHEET:
If FilterOutput = False Or FilteredRowCount = 0 Then
DestinationRange.Resize(UBound(RawOutputArray, 1) + 1, UBound(RawOutputArray, 2) + 1) = RawOutputArray
Else 'FilterOutput = True
'RESIZE THE OUTPUT ARRAY TO EXCLUDE FILTERED ROWS:
ReDim FilteredOutputArray(RowCount - FilteredRowCount, ColumnCount - 1)
Dim xPointer As Integer: xPointer = 0
'COPY THE DATA OVER BUT ONLY IF THE ROW IS GOOD:
For xRow = 0 To RowCount 'HEADER IS ONE ROW
If FilterOutRows(xRow) = False Then
For xColumn = 0 To ColumnCount - 1
FilteredOutputArray(xPointer, xColumn) = RawOutputArray(xRow, xColumn)
Next xColumn
xPointer = xPointer + 1
End If 'FilterOutRows...
Next xRow
'WRITE THE FILTERED RESULT TO THE SHEET:
DestinationRange.Resize(UBound(FilteredOutputArray, 1) + 1, UBound(FilteredOutputArray, 2) + 1) = FilteredOutputArray
End If 'FilterOutput
'UNCOMMENT IF YOU WISH TO SEE THE FilterOutRow TAGS (SORT THE MAIN ARRAY ASCENDING)
'DestinationRange.Offset(, 8).CurrentRegion.ClearContents
'DestinationRange.Offset(, 8).Resize(UBound(RawOutputArray, 1) + 1, 1) = WorksheetFunction.Transpose(FilterOutRows)
'YOU REVERSE THE DATE ORDER USING THIS LINE, IF YOU WROTE A HEADER SET xlYes OTHERWISE xlNo
'key1 IS THE FIRST COLUMN, Date, USE DestinationRange.offset(,<number>) IF DATE IS IN ANOTHER COLUMN
DestinationRange.CurrentRegion.Sort key1:=DestinationRange.Offset(, 0), order1:=DateOrder, Header:=xlYes
'PROBABLY NO ERROR IF YOU GOT HERE
GetYahooRequest = ""
Exit Function
ErrorHandler:
If xColumn = 0 Then
If ParseError <> "" Then ParseError = ParseError & " Maybe its a bad symbol." Else ParseError = "No response. Maybe the network is unavailable."
End If
GetYahooRequest = ParseError
End Function
'ParseField IS CALLED FOR EACH JSON KEY, E.G. "open", "high", "low", "close", ETC.
Function ParseField(ByRef ResponseString As String, strKeyName As String, ByRef strHoldArray() As String) As String
Dim strDQ As String: strDQ = """" 'A SINGLE DOUBLE QUOTE. GO FIGURE.
Dim StartPos As Long, EndPos As Long, x As Long
Dim StringToFind As String
Dim CSVField As String
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False
'1.0d ADDED INITIAL """" SO adjclose and nonadjclose ARE NOT MISTAKEN FOR close
'THANKS TO Jonathan Garneau FOR SUGGESTING THIS FIX
StringToFind = """" & strKeyName & """" & ":["
'EXTRACT THE FIELD OF INTEREST: WE USE BINARY COMPARE AS IT IS FASTER, BUT REMEMBER, IT'S CASE SENSITIVE
'SOME KEY NAMES ARE REPEATED, THE LAST OCCURRENCE SEEMS TO GIVE THE DESIRED RESULTS, HENCE THE LOOP
Do
StartPos = x
x = InStr(StartPos + 1, ResponseString, StringToFind, vbBinaryCompare)
Loop While x <> 0
'CHECK THAT THE STRING WAS FOUND:
If StartPos = 0 Then
ParseField = "Unable to find key " & strKeyName & " in JSON response."
GoTo ErrorHandler
End If
'MOVE THE POINTER TO THE START OF THE DATA
StartPos = StartPos + Len(StringToFind)
'FIND THE END OF THE DATA
EndPos = InStr(StartPos, ResponseString, "]", vbBinaryCompare)
If EndPos = 0 Then
ParseField = "Unable to find closing ] for " & strKeyName & " in JSON response."
GoTo ErrorHandler
End If
'EXTRACT THE DATA AS A STRING:
CSVField = Mid(ResponseString, StartPos, EndPos - StartPos)
'REMOVE THE COMMAS AND PUT INTO THE HOLDING ARRAY:
strHoldArray = Split(CSVField, ",")
'IF YOU GET THIS FAR, PROBABLY NO ERRORS:
ParseField = ""
ErrorHandler:
End Function
