VBA help - yahoo finance downloader

[seller62]

I am not an expert VBA programmer at all.... I found some time ago a macro for downloading historical data from Yahoo finance.
It has always worked great until 2 days ago, now I keep getting a run time error (see image attached). If I hit "debug" the error points to the code line highlighted in the other image.

This is the macro I created using the Sub GetStock (found online). The value of Cells(2,3) is today's date:

Sub GetStock(ByVal stockSymbol As String, ByVal StartDate As Date, ByVal EndDate As Date)

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
Set httpReq = New WinHttp.WinHttpRequest

Application.ScreenUpdating = False

DownloadURL = "Symbol Lookup from Yahoo Finance" & stockSymbol
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

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/" & stockSymbol & "?period1=" & period1 & "&period2=" & period2 & "&interval=1d&events=history&crumb=" & crumb
With httpReq
.Open "GET", DownloadURL, False
.setRequestHeader "Cookie", cookie
.send
.waitForResponse
dataResult = .responseText
End With

dataResult = Replace(dataResult, ",", vbTab)

Dim dataObj As New DataObject
dataObj.SetText dataResult
dataObj.PutInClipboard

Set currentWorksheet = ThisWorkbook.ActiveSheet
Set currentRange = currentWorksheet.Range("A1")
dataObj.GetFromClipboard
currentRange.PasteSpecial

ActiveWindow.SmallScroll Down:=-12
Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1))
Columns("A:F").EntireColumn.AutoFit
Range("A1").Select

Application.ScreenUpdating = True

End Sub


Sub Download()

Sheet3.Activate
T = Cells(2, 3).Value + 1
B = T - 548

Sheet2.Activate
Cells.ClearContents
Call GetStock("SPY", B, T)

Sheet5.Activate
Call GetStock("SPXL", B, T)

Sheet1.Activate
Cells.ClearContents
Call GetStock("^VIX", B, T)

Sheet4.Activate
Cells.ClearContents
Call GetStock("^GSPC", B, T)


Sheet3.Activate

End Sub

 

[pab49162]

I ran into the same problem today and believe the issue is that Yahoo is no longer returning a Set-Cookie HTTP response header.

The solution that worked for me was to simply comment out this line. To do so, simply add two single quote marks like this

'' cookie = Split(.getResponseHeader("Set-Cookie"), ";")(0)

I also needed to comment out one other line where the cookie variable was used later in the program. Here is that line after being commented out

'' .setRequestHeader "Cookie", cookie

If your are code similar to what I have, you will probably need to make this change as well.

Hope this helps ... Paul

 

[sumdumgai]

Hello. Did the above change fix your problem? I have the exact problem. Thanks.

 

[seller62]

Yes it worked!

Thanks a lot very much

 

[pab49162]

seller62 - Glad to hear my suggested solution fixed your issue.

 

[sumdumgai]

Can I please ask what version of Excel you are using and what reference library do you use? Thanks.

 

[pab49162]

sumdumgai - I have used both Excel 2013 and Excel 2021 with the VBA code. The library code doesn't really have a name but I found this in the file header

' Samir Khan, simulationconsultant@gmail.com
' http://investexcel.net/multiple-stock-quote-downloader-for-excel/
' Modified by Tony Alquiza, aka.tonyyy@gmail.com, 180910

 

[sverrealbech]

Does anyone have an excel-sheet with this code? Thx!

 

[vishu]

Does anyone have an excel-sheet with this code? Thx!

hi

'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, pct As Double
    

    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationAutomatic
    
    Set DataSheet = ActiveSheet

    N = Range("C1")

    Clear                           ' clear old data
    Init                            ' paste headings
    
' ----------------------------------


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)
                          ' download one stock
    
   Application.ScreenUpdating = False
   
    Range("K2:AA6").Select           ' collect calculations
    Selection.Copy
       
    Sheets("Calculations").Select      ' move to Calculations sheet
    'Cells(i + 2, 1).Select      ' select proper row and paste calculations
    Cells((i - 1) * 5 + 2, 1).Select         ' select proper row and paste calculations
    
    Selection.PasteSpecial xlAll
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
        Sheets("Download").Select           ' move to Data sheet

    Application.ScreenUpdating = True
    
Next i

    Range("A1").Select
    Selection.ClearContents

    Sheets("Calculations").Select
    Formats
    Range("C1").Select
    Sorting
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 Sorting()
    Dim lr As Long
    Application.ScreenUpdating = False
    With Sheets("Calculations")
        lr = .Range("a" & Rows.Count).End(xlUp).Row
        
              With .Range("S12:S" & lr)
            .Cells(1).FormulaArray = "=text(index(I$1:I$3000,min(if(I12:I$3000<>""""," & _
            "row(I12:I$3000)))),""0000-"")&text(10000-code(index(R$1:R$3000,min(if(R12:R$3000<>""""," & _
            "row(R12:R$3000))))),""000-"")&text(10000-row(),""0000"")"
            .FillDown
        End With

       .Range("a12:S" & lr).Sort .Columns("S"), 1
        .Columns("S").ClearContents
    End With
    Application.ScreenUpdating = True
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:Q10000").ClearContents      ' CLEAR OLD STUFF

     Worksheets("Download").Range("C8:I600").ClearContents      ' CLEAR OLD STUFF

    
    Formats
    Sheets("Download").Select      ' move back
    
End Sub
Sub Move()
'
' Move Macro
' Macro recorded 09/03/2007 by pjPonzo
'

    Range("C7:C600").Select
    Selection.Copy
    Range("K7").Select
    ActiveSheet.Paste
    
    Range("I7:I600").Select
    Selection.Copy
    Range("L7").Select
    ActiveSheet.Paste

End Sub

Sub Init()
'
' Init Macro
' Macro recorded 09/03/2007 by pjPonzo
'

'
 Range("K1:AA1").Copy Destination:=Sheets("Calculations").[A1]
    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("D8:Z8").Select
    Selection.Copy
    Range("D9:Z600").Select
    Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
        
    Range("A1").Select
    Selection.ClearContents
    
End Sub

above code was working but last two days giving no result if any one have solution than please help