Dim gError As Integer
Sub GetData()
Dim QuerySheet As Worksheet
Dim DataSheet As Worksheet
Dim Symbol As String
Dim i As Integer, N As Integer, p As Integer
Dim last As Double
Dim OffsetCounter As Double
Application.DisplayAlerts = False
Application.Calculation = xlCalculationAutomatic
Set DataSheet = ActiveSheet
Set QuerySheet = Sheets("Download")
Set DataSheet = Sheets("Calculations")
With QuerySheet
last = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
N = Range("C1")
Clear
Init
For i = 1 To N
Range("A1") = i
Range("B4") = Cells(i + 7, 1)
Cells(i + 7, 1).Select
Call GetOne(Worksheets("Download").Range("$B$4"), Worksheets("Download").Range("$B$2"), Worksheets("Download").Range("$B$3"), "$A$1", freqFlag)
Application.ScreenUpdating = False
Range("K5:P10").Select
Selection.Copy
Sheets("Calculations").Select
Cells(i + 2, 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Sheets("Download").Select
Application.ScreenUpdating = True
OffsetCounter = 1
Call ExtractData(Symbol, OffsetCounter)
Next i
Range("A1").Select
Selection.ClearContents
DataSheet.Columns("A:F").AutoFit
Sheets("Calculations").Select
Formats
Range("C1").Select
End Sub
Sub GetOne(ByVal Symbol As String, ByVal startDate As Date, ByVal endDate As Date, ByVal desti As String, ByVal freq As String)
On Error GoTo ErrHandler:
Dim crumb As String
Dim cookie As String
Dim response As String
Dim strUrl As String
Dim DownloadURL As String
Dim period1, period2 As String
Dim httpReq As WinHttp.WinHttpRequest
Dim nQuery As Name
Set httpReq = New WinHttp.WinHttpRequest
DownloadURL = "https://finance.yahoo.com/lookup?s=" & Symbol
With httpReq
.Open "GET", DownloadURL, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
.send
.waitForResponse
response = .ResponseText
cookie = Split(.getResponseHeader("Set-Cookie"), ";")(0)
End With
period1 = (startDate - DateValue("January 1, 1970")) * 86400
period2 = (endDate - DateValue("January 1, 1970")) * 86400
Dim counter As Long
Dim startCounter As Long
Dim result As String
Dim dataResult As String
Dim startResult As String
crumb = Chr(34) & "CrumbStore" & Chr(34) & ":{" & Chr(34) & "crumb" & Chr(34) & ":" & Chr(34)
startCounter = InStr(response, crumb) + Len(crumb)
While Mid(response, startCounter, 1) <> Chr(34)
result = result & Mid(response, startCounter, 1)
startCounter = startCounter + 1
Wend
crumb = result
DownloadURL = "https://query1.finance.yahoo.com/v7/finance/download/" & Symbol & "?period1=" & period1 & "&period2=" & period2 & "&interval=" + freq + "&events=history&crumb=" & crumb
startResult = ""
startCounter = 0
While (startResult <> "Date" And startCounter < 8)
With httpReq
.Open "GET", DownloadURL, False
.setRequestHeader "Cookie", cookie
.send
.waitForResponse
dataResult = .ResponseText
End With
startResult = Mid(dataResult, 1, 4)
startCounter = startCounter + 1
Wend
If (startResult <> "Date") Then
noErrorFound = 0
GoTo ErrHandler
End If
dataResult = Replace(dataResult, ",", vbTab)
Dim dataObj As New DataObject
dataObj.SetText dataResult
dataObj.PutInClipboard
Set currentWorksheet = ThisWorkbook.ActiveSheet
Set currentRange = currentWorksheet.Range("C7")
dataObj.GetFromClipboard
currentRange.PasteSpecial
noErrorFound = 1
ErrHandler:
If noErrorFound = 0 Then
Application.ScreenUpdating = True
End If
Resume Next
Range("C1:I1").Select
Selection.ColumnWidth = 8
Application.DisplayAlerts = True
Range("C8:I600").Select
Selection.Sort Key1:=Range("C8"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
RemoveNames
Range("A1").Select
End Sub
Sub ExtractData(Symbols As String, OffsetCounter As Double)
Dim csv_rows() As String
Dim resultArray As Variant
Dim nColumns As Integer
Dim iRows As Integer
Dim CSV_Fields As Variant
Dim iCols As Integer
nColumns = 6
csv_rows = Filter(csv_rows, csv_rows(0), False)
ReDim resultArray(0 To UBound(csv_rows), 0 To nColumns) As Variant
For iRows = LBound(csv_rows) To UBound(csv_rows)
CSV_Fields = Split(csv_rows(iRows), ",")
If UBound(CSV_Fields) > nColumns Then
nColumns = UBound(CSV_Fields)
ReDim Preserve resultArray(0 To UBound(csv_rows), 0 To nColumns) As Variant
End If
For iCols = LBound(CSV_Fields) To UBound(CSV_Fields)
If IsNumeric(CSV_Fields(iCols)) Then
resultArray(iRows, iCols) = Val(CSV_Fields(iCols))
ElseIf IsDate(CSV_Fields(iCols)) Then
resultArray(iRows, iCols) = CDate(CSV_Fields(iCols))
Else
resultArray(iRows, iCols) = CStr(CSV_Fields(iCols))
End If
Next
Next
Sheets("Calculations").Select
Range("A1000000").End(xlUp).Offset(OffsetCounter, 0).Select
Selection.Resize(UBound(resultArray, 1) + 1, UBound(resultArray, 2) + 1).Value = resultArray
Range("H1000000").End(xlUp).Offset(OffsetCounter, 0).Select
Selection.Resize(UBound(resultArray, 1) + 1, 1).Value = Symbols
End Sub
Sub RemoveNames()
Dim nQuery As Name
For Each nQuery In Names
If IsNumeric(Right(nQuery.Name, 1)) Then
nQuery.Delete
End If
Next nQuery
End Sub
Sub Clear()
Sheets("Calculations").Select
Worksheets("Calculations").Range("A1:F600").ClearContents
Worksheets("Download").Range("C8:I600").ClearContents
Formats
Sheets("Download").Select
End Sub
Sub Init()
Range("K3:P10").Select
Selection.Copy
Sheets("Calculations").Select
Range("A1:P2000").Select
ActiveSheet.Paste
Sheets("Download").Select
End Sub
Sub DownloadData()
Application.ScreenUpdating = False
Dim freqFlag As String
Dim numRows As Integer
Dim noErrorFoundInDownloadData As Integer
noErrorFoundInDownloadData = 0
On Error GoTo ErrHandlerDownloadData:
freqFlag = "1d"
If Worksheets("Download").Range("$B$5") = 1 Then
freqFlag = "1d"
numRows = DateDiff("d", Worksheets("Download").Range("$B$2"), Worksheets("Download").Range("$B$3")) + 2
ElseIf Worksheets("Download").Range("$B$5") = 2 Then
freqFlag = "1wk"
numRows = DateDiff("w", Worksheets("Download").Range("$B$2"), Worksheets("Download").Range("$B$3")) + 2
ElseIf Worksheets("Download").Range("$B$5") = 3 Then
freqFlag = "1mo"
numRows = DateDiff("m", Worksheets("Download").Range("$B$2"), Worksheets("Download").Range("$B$3")) + 2
End If
Worksheets("Download").Select
If Worksheets("Download").Range("$C$13") <> "NONE" Then
Call GetOne(Worksheets("Download").Range("$B$4"), Worksheets("Download").Range("$B$2"), Worksheets("Download").Range("$B$3"), "$A$1", freqFlag)
End If
Range("C7").Select
Columns("C:J").EntireColumn.AutoFit
Dim vvx As Integer
vvx = Application.Version
If (vvx >= 12) Then
ActiveWorkbook.Worksheets("Download").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Download").Sort.SortFields.Add Key:=Range("C8:C6550") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Download").Sort
.SetRange Range("C7:J65500")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Else
Columns("C:J").Select
Selection.Sort Key1:=Range("C8"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End If
Worksheets("Download").Select
Worksheets("Download").Range("J8").Select
noErrorFoundInDownloadData = 1
Application.ScreenUpdating = True
ErrHandlerDownloadData:
End Sub
Sub Formats()
Range("A1:P1").Select
Selection.Copy
Range("A10:P6000").Select
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("A1").Select
Selection.ClearContents
End Sub