'Copyright 2008-2018 ConnectCode Pte Ltd. All Rights Reserved.
'This source code is protected by International Copyright Laws.
Dim gError As Integer
Sub GetData()
' thanks to Ron McEwan :^)
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 ' clear old data
Init ' paste headings
' ExtractData
' ----------------------------------
For i = 1 To N
Range("A1") = i
Range("B4") = Cells(i + 7, 1) ' get symbol
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 ' collect calculations
Selection.Copy
Sheets("Calculations").Select ' move to Calculations sheet
Cells(i + 2, 1).Select ' select proper row and paste calculations
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Sheets("Download").Select ' move to Data sheet
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
' MsgBox ("Stock " + Symbol + "DONE")
End If
Resume Next
Range("C1:I1").Select
Selection.ColumnWidth = 8
'turn calculation back on
Application.DisplayAlerts = True
Range("C8:I600").Select
Selection.Sort Key1:=Range("C8"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
RemoveNames
'UpdateScale
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()
'
' Clear Macro
' Macro recorded 8/13/2006 by Ponzo
Sheets("Calculations").Select ' move to Calculations sheet
Worksheets("Calculations").Range("A1:F600").ClearContents ' CLEAR OLD STUFF
Worksheets("Download").Range("C8:I600").ClearContents ' CLEAR OLD STUFF
Formats
Sheets("Download").Select ' move back
End Sub
Sub Init()
' Init Macro
' Macro recorded 09/03/2007 by pjPonzo
'
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"
'plus 2 due to the intitial two rows
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
' Worksheets("Download").UsedRange.Clear
'Stock 1
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
'Excel 2007
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
'Exel 2003
Columns("C:J").Select
Selection.Sort Key1:=Range("C8"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End If
'End If
Worksheets("Download").Select
Worksheets("Download").Range("J8").Select
noErrorFoundInDownloadData = 1
Application.ScreenUpdating = True
ErrHandlerDownloadData:
End Sub
Sub Formats()
'
' Formats Macro
' Macro recorded 9/5/2008 by pjPonzo
'
'
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