Excel VBA Scraper from Yahoo Finance Question (completely stuck!)

R

reacon84

New Member
Joined
Sep 13, 2016
Messages
38
Office Version
  1. 2016
Platform
  1. Windows
I'm trying to scrape some Yahoo Finance data from their website, and I've inherited some VBA which allows me to do this mostly.

However, as you can see from the picture, I have a problem where the script tries to scrape a field that is blank. If it's blank, I want to put an "N/A" return in the field, rather than just putting the 'next' field in it's place.

1601665867884.png


VBA Code: 
Sub qTest_3()
    
    Call clear_data
    
    Dim myrng As Range
    Dim lastrow As Long
    Dim row_count As Long
    Dim ws As Worksheet
    Set ws = Sheets("Main")
    
    col_count = 2
    row_count = 2
    
    'Find last row
    With ws
     lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
    End With
    
    'set ticker range
    Set myrng = ws.Range(Cells(2, 1), Cells(lastrow, 1))
 
    'llop through tickers
    For Each ticker In myrng
    
        'Send web request
        Dim URL2 As String: URL2 = "https://finance.yahoo.com/quote/" & ticker & "/key-statistics?p=" & ticker
        Dim Http2 As New WinHttpRequest
    
        Http2.Open "GET", URL2, False
        Http2.Send
    
        Dim s As String
        'Get source code of site
        s = Http2.ResponseText
            
            Dim metrics As Variant
            '**** Metric fields here
            metrics = Array("dividendRate", "dividendYield", "fiveYearAvgDividendYield", "trailingAnnualDividendRate", "exDividendDate")
            

            'Split string here
            For Each element In metrics
    
    
                firstTerm = Chr(34) & element & Chr(34) & ":{" & Chr(34) & "raw" & Chr(34) & ":"
                secondTerm = "," & Chr(34) & "fmt" & Chr(34)
                
                nextPosition = 1
            
                On Error GoTo err_hdl
                
                Do Until nextPosition = 0
                    startPos = InStr(nextPosition, s, firstTerm, vbTextCompare)
                    stopPos = InStr(startPos, s, secondTerm, vbTextCompare)
                    split_string = Mid$(s, startPos + Len(firstTerm), stopPos - startPos - Len(secondTerm))
                    nextPosition = InStr(stopPos, s, firstTerm, vbTextCompare)
                    
                    Exit Do
                Loop
                
                On Error GoTo 0
                
                
                Dim arr() As String
                arr = Split(split_string, ",")
                metric = arr(0)
                
                'Output to sheet
                ws.Range(Cells(row_count, col_count), Cells(row_count, col_count)).Value = metric
                col_count = col_count + 1
                 
getData:
            
            Next element
            
            Dim symbol As String
            symbol = ticker
            
            col_count = 2
            row_count = row_count + 1
        
    Next ticker
    
    MsgBox ("Done")
    
    Exit Sub

err_hdl:
    ws.Range(Cells(row_count, col_count), Cells(row_count, col_count)).Value = "N/A"
    Resume getData
    
End Sub

Sub clear_data()

    Dim ws As Worksheet
    Set ws = Sheets("Main")
    Dim lastrow, lastcol As Long
    Dim myrng As Range
    
    With ws
     lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
    End With
    
    lastcol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
    
    Set myrng = ws.Range(Cells(2, 2), Cells(lastrow, lastcol))
    
    myrng.Clear
    
End Sub

Would anyone be able to help me to fix this?

Thanks in advance!
 
Sort by date Sort by votes
Just revisiting this again!

I'm trying to alter the code after inserting a new column, but I can't grasp how to stop it deleting the wrong thing! I only need the dividend amount now.

I just want the code to return the dividend amount in the yellow cells.

1643218758487.png


But I keep getting this result!

1643218877894.png


As ever, any help is greatly appreciated, and thanks in advance.
 
Upvote 0

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
reacon84 said:
Just revisiting this again!

I'm trying to alter the code after inserting a new column, but I can't grasp how to stop it deleting the wrong thing! I only need the dividend amount now.

I just want the code to return the dividend amount in the yellow cells.

View attachment 56201

But I keep getting this result!

View attachment 56202

As ever, any help is greatly appreciated, and thanks in advance.
Click to expand...
VBA Code: 
Private Sub qTest_3()

Dim Data_Output() As Variant, Tickers() As Variant, ws As Worksheet, Last_Row As Long, Z As Long, B As Long, Response_STR As String

Dim URL2 As String, metrics() As Variant, Element As String, Http2 As Object, N As Long

Dim FirstTerm As String, SecondTerm As String, NextPosition As Double, StartPos As Double, StopPos As Double

Call clear_data

Const Ticker_Column As String = "B"
Const data_output_column_start As String = "C"

Set ws = ThisWorkbook.Sheets("Main")

With ws
    Last_Row = .Range("A" & .Rows.Count).End(xlUp).Row
    Tickers = .Range(Ticker_Column & 2, Ticker_Column & Last_Row).Value 'Take tickers from column B
End With

metrics = Array("dividendRate") ', "dividendYield", "fiveYearAvgDividendYield", "trailingAnnualDividendRate", "exDividendDate")

ReDim Data_Output(1 To UBound(Tickers, 1), 1 To UBound(metrics) + IIf(LBound(metrics) = 0, 1, 0))

SecondTerm = "," & Chr(34) & "fmt" & Chr(34)                     ',"fmt"

Set Http2 = CreateObject("Msxml2.ServerXMLHTTP")

For Z = 1 To UBound(Tickers, 1)

    URL2 = "https://finance.yahoo.com/quote/" & Tickers(Z, 1) & "/key-statistics?p=" & Tickers(Z, 1)
   
    Http2.Open "GET", URL2, False
    Http2.send
    Response_STR = Http2.responseText
   
    B = 1
   
    For N = LBound(metrics) To UBound(metrics) 'Each Element In metrics
        
        Element = metrics(N)
        
        FirstTerm = Chr(34) & Element & Chr(34) & ":{" & Chr(34) & "raw" & Chr(34) & ":"  'Example  "dividendRate":{"raw":
        NextPosition = 1    'Starting character to search from set to the 1st
       
        StartPos = InStr(NextPosition, Response_STR, FirstTerm, vbTextCompare) 'Find location of 1st Term
       
        If StartPos <> 0 Then 'If the FirstTerm is found after NextPosition then search for the SecondTerm
       
            StopPos = InStr(StartPos, Response_STR, SecondTerm, vbTextCompare)  'Find location of 2nd Term starting at the location of the 1st Term
           
            If StopPos <> 0 Then 'Find string in-between that doesn't intersect with either term
                Data_Output(Z, B) = Mid$(Response_STR, StartPos + Len(FirstTerm), StopPos - (StartPos + Len(FirstTerm)))
            Else
                Data_Output(Z, B) = "N/A"
            End If
           
        Else
            Data_Output(Z, B) = "N/A"
        End If
       
        B = B + 1

    Next N
   
Next Z

ws.Range(data_output_column_start & 2).Resize(UBound(Data_Output, 1), UBound(Data_Output, 2)).Value = Data_Output

Set Http2 = Nothing

MsgBox "Done"

End Sub
 
Upvote 0
Thank you MoshiM for your reply.

I'm getting closer!

1643281814260.png


It now seems to delete the existing dividend amounts, but also deletes the tickers, so returns N/A in the dividend column.

Is there something wrong with my clear_data code? Thanks again for your help!

Sub clear_data()

Dim ws As Worksheet
Set ws = Sheets("Main")
Dim lastrow, lastcol As Long
Dim myrng As Range

With ws
lastrow = .Range("C" & .Rows.Count).End(xlUp).Row
End With

lastcol = ws.Cells(1, Columns.Count).End(xlToLeft).Column

Set myrng = ws.Range(Cells(2, 2), Cells(lastrow, lastcol))

myrng.Clear

End Sub
Click to expand...
 
Upvote 0
reacon84 said:
Thank you MoshiM for your reply.

I'm getting closer!

View attachment 56250

It now seems to delete the existing dividend amounts, but also deletes the tickers, so returns N/A in the dividend column.

Is there something wrong with my clear_data code? Thanks again for your help!
Click to expand...
change cells(2,2) to cells(2,3) in your clear data code
 
Upvote 0
Honestly, I can't express how thankful I am for your help!

Thank you SO MUCH!!

You are a wizard!
 
Upvote 0
Just as a follow up, the code has unfortunately stopped working now, I think something has changed in Yahoo Finance?

From what I can see, the source has changed from "dividendRate" but I can't see to what?

Thanks in advance
 
Upvote 0
abhi221996 said:
here's an excel application might help you to get data by using yahoo finance by just using Tickers.
with the source code given below and application in the image for your reference .
VBA Code: 
Option Explicit
Public Const firstTickerRow As Integer = 13

Sub DownloadData()

    Dim frequency As String
    Dim lastRow As Integer
    Dim lastErrorRow As Integer
    Dim lastSuccessRow As Integer
    Dim stockTicker As String
    Dim numStockErrors As Integer
    Dim numStockSuccess As Integer
    Dim startDate As String
    Dim endDate As String
    Dim ticker As Integer
    
    Dim crumb As String
    Dim cookie As String
    Dim validCookieCrumb As Boolean
    
    Dim sortOrderComboBox As Shape
 
    numStockErrors = 0
    numStockSuccess = 0

    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    lastErrorRow = ActiveSheet.Cells(Rows.Count, "J").End(xlUp).Row
    lastSuccessRow = ActiveSheet.Cells(Rows.Count, "L").End(xlUp).Row

    ClearErrorList lastErrorRow
    ClearSuccessList lastSuccessRow

    lastRow = ActiveSheet.Cells(Rows.Count, "a").End(xlUp).Row
    frequency = Worksheets("Parameters").Range("b7")
    
    'Convert user-specified calendar dates to Unix time
    '***************************************************
    startDate = (Sheets("Parameters").Range("startDate") - DateValue("January 1, 1970")) * 86400
    endDate = (Sheets("Parameters").Range("endDate") - DateValue("January 1, 1970")) * 86400
    '***************************************************
    
    'Set date retrieval frequency
    '***************************************************
    If Worksheets("Parameters").Range("frequency") = "d" Then
        frequency = "1d"
    ElseIf Worksheets("Parameters").Range("frequency") = "w" Then
        frequency = "1wk"
    ElseIf Worksheets("Parameters").Range("frequency") = "m" Then
        frequency = "1mo"
    End If
    '***************************************************

    'Delete all sheets apart from Parameters sheet
    '***************************************************
    Dim ws As Worksheet
    For Each ws In Worksheets
        If ws.Name <> "Parameters" And ws.Name <> "About" Then ws.Delete
    Next
    '***************************************************

    'Get cookie and crumb
    '***************************************************
    Call getCookieCrumb(crumb, cookie, validCookieCrumb)
    If validCookieCrumb = False Then
        GoTo ErrorHandler:
    End If
    '***************************************************

    'Loop through all tickers
    For ticker = firstTickerRow To lastRow

        stockTicker = Worksheets("Parameters").Range("$a$" & ticker)

        If stockTicker = "" Then
            GoTo NextIteration
        End If

        'Create a sheet for each ticker
        '***************************************************
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = stockTicker
        Cells(1, 1) = "Stock Quotes for " & stockTicker
        '***************************************************

        'Get financial data from Yahoo and write into each sheet
        'getCookieCrumb() must be run before running getYahooFinanceData()
        '***************************************************
        Call getYahooFinanceData(stockTicker, startDate, endDate, frequency, cookie, crumb)
        '***************************************************
        
        'The Yahoo data swaps around the close and adjusted close prices - gremlin in Yahoo probably
        'Let's just swap around the labels as a workaround
        '***************************************************
'        Sheets(stockTicker).Range("E2") = "Adjusted Close"
'        Sheets(stockTicker).Range("F2") = "Close"
        
        'Populate success or fail lists
        '***************************************************
        lastRow = Sheets(stockTicker).UsedRange.Row - 2 + Sheets(stockTicker).UsedRange.Rows.Count

        If lastRow < 3 Then
            Sheets(stockTicker).Delete
            numStockErrors = numStockErrors + 1
            ErrorList stockTicker, numStockErrors
            GoTo NextIteration
        Else
            numStockSuccess = numStockSuccess + 1
            If Left(stockTicker, 1) = "^" Then
                SuccessList Replace(stockTicker, "^", ""), numStockSuccess
            Else
                SuccessList stockTicker, numStockSuccess
            End If
        End If
        '***************************************************

        'Set the preferred date format
        '***************************************************
        Range("a3:a" & lastRow).NumberFormat = "yyyy-mm-dd;@"
        '***************************************************
        
        'Sort by oldest date first or newest date first
        '***************************************************
        Set sortOrderComboBox = Sheets("Parameters").Shapes("SortOrderDropDown")
        With sortOrderComboBox.ControlFormat
            If .List(.Value) = "Oldest First" Then
                Call SortByDate(stockTicker, "oldest")
            ElseIf .List(.Value) = "Newest First" Then
                Call SortByDate(stockTicker, "newest")
            End If
        End With
        '***************************************************
        
        'Clean up sheet names
        '***************************************************
        'Remove initial ^ in ticker names from Sheets
        If Left(stockTicker, 1) = "^" Then
            ActiveSheet.Name = Replace(stockTicker, "^", "")
        Else
            ActiveSheet.Name = stockTicker
        End If

        'Remove hyphens in ticker names from Sheet names, otherwise error in collation
        If InStr(stockTicker, "-") > 0 Then
            ActiveSheet.Name = Replace(stockTicker, "-", "")
        End If
        '***************************************************

NextIteration:
    Next ticker
    
    'Process export and collation
    '***************************************************
    If Sheets("Parameters").Shapes("WriteToCSVCheckBox").ControlFormat.Value = xlOn Then
        On Error GoTo ErrorHandler:
        Call CopyToCSV
    End If

    If Sheets("Parameters").Shapes("CollateDataCheckBox").ControlFormat.Value = xlOn Then
        On Error GoTo ErrorHandler:
        Call CollateData
    End If
    '***************************************************
ErrorHandler:

    Worksheets("Parameters").Select
    
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

Sub SortByDate(ticker As String, order As String)
    
    Dim firstRow As Integer
    Dim lastRow As Integer
    Dim sortType As Variant
    
    lastRow = Sheets(ticker).UsedRange.Rows.Count
    firstRow = 2
    
    If order = "oldest" Then
       sortType = xlAscending
    Else
       sortType = xlDescending
    End If
    
    Worksheets(ticker).Sort.SortFields.Clear
    Worksheets(ticker).Sort.SortFields.Add Key:=Sheets(ticker).Range("A" & firstRow & ":A" & lastRow), _
        SortOn:=xlSortOnValues, order:=sortType, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(ticker).Sort
        .SetRange Range("A" & firstRow & ":G" & lastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
End Sub


Sub CollateData()

    Dim ws As Worksheet
    Dim i As Integer
    Dim maxRow As Integer
    Dim maxTickerWS As Worksheet

    maxRow = 0
    For Each ws In Worksheets
        If ws.Name <> "Parameters" Then
            If ws.UsedRange.Rows.Count > maxRow Then
                maxRow = ws.UsedRange.Rows.Count
                Set maxTickerWS = ws
            End If
        End If
    Next

    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "Open Price"

    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "High Price"

    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "Low Price"

'Correct a bug in the Yahoo Finance data
'****************************************
'    Sheets.Add After:=Sheets(Sheets.Count)
'    ActiveSheet.Name = "Close Price"
'
'    Sheets.Add After:=Sheets(Sheets.Count)
'    ActiveSheet.Name = "Trading Volume"
'
'    Sheets.Add After:=Sheets(Sheets.Count)
'    ActiveSheet.Name = "Adjusted Close Price"

    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "Close Price"

    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "Adjusted Close Price"

    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "Trading Volume"
'****************************************
    i = 1
    
    maxTickerWS.Range("A2", "B" & maxRow).Copy Destination:=Sheets("Open Price").Cells(1, i)
    Sheets("Open Price").Cells(1, i + 1) = maxTickerWS.Name

    maxTickerWS.Range("A2", "a" & maxRow).Copy Destination:=Sheets("High Price").Cells(1, i)
    maxTickerWS.Range("c2", "c" & maxRow).Copy Destination:=Sheets("High Price").Cells(1, i + 1)
    Sheets("High Price").Cells(1, i + 1) = maxTickerWS.Name

    maxTickerWS.Range("A2", "a" & maxRow).Copy Destination:=Sheets("Low Price").Cells(1, i)
    maxTickerWS.Range("d2", "d" & maxRow).Copy Destination:=Sheets("Low Price").Cells(1, i + 1)
    Sheets("Low Price").Cells(1, i + 1) = maxTickerWS.Name

'Correct a bug in the Yahoo Finance data
'****************************************
    maxTickerWS.Range("A2", "a" & maxRow).Copy Destination:=Sheets("Close Price").Cells(1, i)
    maxTickerWS.Range("e2", "e" & maxRow).Copy Destination:=Sheets("Close Price").Cells(1, i + 1)
    Sheets("Close Price").Cells(1, i + 1) = maxTickerWS.Name

    maxTickerWS.Range("A2", "a" & maxRow).Copy Destination:=Sheets("Adjusted Close Price").Cells(1, i)
    maxTickerWS.Range("f2", "f" & maxRow).Copy Destination:=Sheets("Adjusted Close Price").Cells(1, i + 1)
    Sheets("Trading Volume").Cells(1, i + 1) = maxTickerWS.Name

    maxTickerWS.Range("A2", "a" & maxRow).Copy Destination:=Sheets("Trading Volume").Cells(1, i)
    maxTickerWS.Range("g2", "g" & maxRow).Copy Destination:=Sheets("Trading Volume").Cells(1, i + 1)
    Sheets("Adjusted Close Price").Cells(1, i + 1) = maxTickerWS.Name
    
'    maxTickerWS.Range("A2", "a" & maxRow).Copy Destination:=Sheets("Adjusted Close Price").Cells(1, i)
'    maxTickerWS.Range("e2", "e" & maxRow).Copy Destination:=Sheets("Adjusted Close Price").Cells(1, i + 1)
'    Sheets("Adjusted Close Price").Cells(1, i + 1) = maxTickerWS.Name
'
'    maxTickerWS.Range("A2", "a" & maxRow).Copy Destination:=Sheets("Close Price").Cells(1, i)
'    maxTickerWS.Range("f2", "f" & maxRow).Copy Destination:=Sheets("Close Price").Cells(1, i + 1)
'    Sheets("Close Price").Cells(1, i + 1) = maxTickerWS.Name
'
'    maxTickerWS.Range("A2", "a" & maxRow).Copy Destination:=Sheets("Trading Volume").Cells(1, i)
'    maxTickerWS.Range("g2", "g" & maxRow).Copy Destination:=Sheets("Trading Volume").Cells(1, i + 1)
'    Sheets("Trading Volume").Cells(1, i + 1) = maxTickerWS.Name
'****************************************
    i = i + 2

    For Each ws In Worksheets

        If ws.Name <> "Stacked Data" And ws.Name <> "Parameters" And ws.Name <> "About" And ws.Name <> maxTickerWS.Name And ws.Name <> "Open Price" And ws.Name <> "High Price" And ws.Name <> "Low Price" And ws.Name <> "Close Price" And ws.Name <> "Trading Volume" And ws.Name <> "Adjusted Close Price" Then

            Sheets("Open Price").Cells(1, i) = ws.Name
            Sheets("Open Price").Range(Sheets("Open Price").Cells(2, i), Sheets("Open Price").Cells(maxRow - 1, i)).Formula = _
                "=vlookup(A2," & ws.Name & "!A$2:G$" & maxRow & ",2,0)"

            Sheets("High Price").Cells(1, i) = ws.Name
            Sheets("High Price").Range(Sheets("High Price").Cells(2, i), Sheets("High Price").Cells(maxRow - 1, i)).Formula = _
                "=vlookup(A2," & ws.Name & "!A$2:G$" & maxRow & ",3,0)"

            Sheets("Low Price").Cells(1, i) = ws.Name
            Sheets("Low Price").Range(Sheets("Low Price").Cells(2, i), Sheets("Low Price").Cells(maxRow - 1, i)).Formula = _
                "=vlookup(A2," & ws.Name & "!A$2:G$" & maxRow & ",4,0)"

'Correct a bug in the Yahoo Finance data
'****************************************
            Sheets("Close Price").Cells(1, i) = ws.Name
            Sheets("Close Price").Range(Sheets("Close Price").Cells(2, i), Sheets("Close Price").Cells(maxRow - 1, i)).Formula = _
                "=vlookup(A2," & ws.Name & "!A$2:G$" & maxRow & ",5,0)"

            Sheets("Adjusted Close Price").Cells(1, i) = ws.Name
            Sheets("Adjusted Close Price").Range(Sheets("Adjusted Close Price").Cells(2, i), Sheets("Adjusted Close Price").Cells(maxRow - 1, i)).Formula = _
                "=vlookup(A2," & ws.Name & "!A$2:G$" & maxRow & ",6,0)"

            Sheets("Trading Volume").Cells(1, i) = ws.Name
            Sheets("Trading Volume").Range(Sheets("Trading Volume").Cells(2, i), Sheets("Trading Volume").Cells(maxRow - 1, i)).Formula = _
                "=vlookup(A2," & ws.Name & "!A$2:G$" & maxRow & ",7,0)"
                
'            Sheets("Adjusted Close Price").Cells(1, i) = ws.Name
'            Sheets("Adjusted Close Price").Range(Sheets("Adjusted Close Price").Cells(2, i), Sheets("Adjusted Close Price").Cells(maxRow - 1, i)).Formula = _
'                "=vlookup(A2," & ws.Name & "!A$2:G$" & maxRow & ",5,0)"
'
'            Sheets("Close Price").Cells(1, i) = ws.Name
'            Sheets("Close Price").Range(Sheets("Close Price").Cells(2, i), Sheets("Close Price").Cells(maxRow - 1, i)).Formula = _
'                "=vlookup(A2," & ws.Name & "!A$2:G$" & maxRow & ",6,0)"
'
'            Sheets("Trading Volume").Cells(1, i) = ws.Name
'            Sheets("Trading Volume").Range(Sheets("Trading Volume").Cells(2, i), Sheets("Trading Volume").Cells(maxRow - 1, i)).Formula = _
'                "=vlookup(A2," & ws.Name & "!A$2:G$" & maxRow & ",7,0)"
'****************************************
            i = i + 1

        End If
    Next

    On Error Resume Next

    Sheets("Open Price").UsedRange.SpecialCells(xlFormulas, xlErrors).Clear
    Sheets("Close Price").UsedRange.SpecialCells(xlFormulas, xlErrors).Clear
    Sheets("High Price").UsedRange.SpecialCells(xlFormulas, xlErrors).Clear
    Sheets("Low Price").UsedRange.SpecialCells(xlFormulas, xlErrors).Clear
    Sheets("Trading Volume").UsedRange.SpecialCells(xlFormulas, xlErrors).Clear
    Sheets("Adjusted Close Price").UsedRange.SpecialCells(xlFormulas, xlErrors).Clear

    Sheets("Open Price").UsedRange.Value = Sheets("Open Price").UsedRange.Value
    Sheets("Close Price").UsedRange.Value = Sheets("Close Price").UsedRange.Value
    Sheets("High Price").UsedRange.Value = Sheets("High Price").UsedRange.Value
    Sheets("Low Price").UsedRange.Value = Sheets("Low Price").UsedRange.Value
    Sheets("Trading Volume").UsedRange.Value = Sheets("Trading Volume").UsedRange.Value
    Sheets("Adjusted Close Price").UsedRange.Value = Sheets("Adjusted Close Price").UsedRange.Value
    On Error GoTo 0

    Sheets("Open Price").Columns("A:A").EntireColumn.AutoFit
    Sheets("High Price").Columns("A:A").EntireColumn.AutoFit
    Sheets("Low Price").Columns("A:A").EntireColumn.AutoFit
    Sheets("Close Price").Columns("A:A").EntireColumn.AutoFit
    Sheets("Trading Volume").Columns("A:A").EntireColumn.AutoFit
    Sheets("Adjusted Close Price").Columns("A:A").EntireColumn.AutoFit
End Sub

Sub SuccessList(ByVal stockTicker As String, ByVal numStockSuccess As Integer)

    Sheets("Parameters").Range("L" & 10 + numStockSuccess) = stockTicker

    Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlDiagonalDown).LineStyle = xlNone
    Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlDiagonalUp).LineStyle = xlNone
    Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlEdgeLeft).LineStyle = xlNone
    Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlEdgeTop).LineStyle = xlNone
    Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlEdgeBottom).LineStyle = xlNone
    Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlEdgeRight).LineStyle = xlNone
    Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlInsideVertical).LineStyle = xlNone
    Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlInsideHorizontal).LineStyle = xlNone
    Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlDiagonalDown).LineStyle = xlNone
    Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlDiagonalUp).LineStyle = xlNone

    With Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With

    Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlInsideVertical).LineStyle = xlNone
    Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlInsideHorizontal).LineStyle = xlNone

    With Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With

End Sub

Sub ErrorList(ByVal stockTicker As String, ByVal numStockErrors As Integer)

    Sheets("Parameters").Range("J" & 10 + numStockErrors) = stockTicker

    Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlDiagonalDown).LineStyle = xlNone
    Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlDiagonalUp).LineStyle = xlNone
    Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlEdgeLeft).LineStyle = xlNone
    Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlEdgeTop).LineStyle = xlNone
    Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlEdgeBottom).LineStyle = xlNone
    Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlEdgeRight).LineStyle = xlNone
    Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlInsideVertical).LineStyle = xlNone
    Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlInsideHorizontal).LineStyle = xlNone
    Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlDiagonalDown).LineStyle = xlNone
    Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlDiagonalUp).LineStyle = xlNone

    With Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With

    Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlInsideVertical).LineStyle = xlNone
    Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlInsideHorizontal).LineStyle = xlNone

    With Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With

End Sub

Sub ClearErrorList(ByVal lastErrorRow As Integer)
    If lastErrorRow > 10 Then
        Worksheets("Parameters").Range("J11:J" & lastErrorRow).Clear
        With Sheets("Parameters").Range("J10").Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With Sheets("Parameters").Range("J10").Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With Sheets("Parameters").Range("J10").Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With Sheets("Parameters").Range("J10").Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
    End If
End Sub

Sub ClearSuccessList(ByVal lastSuccessRow As Integer)
    If lastSuccessRow > 10 Then
        Worksheets("Parameters").Range("L11:L" & lastSuccessRow).Clear
        With Sheets("Parameters").Range("L10").Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With Sheets("Parameters").Range("L10").Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With Sheets("Parameters").Range("L10").Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With Sheets("Parameters").Range("L10").Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
    End If
End Sub

Sub CopyToCSV()

    Dim MyPath As String
    Dim MyFileName As String
    Dim dateFrom As Date
    Dim dateTo As Date
    Dim frequency As String
    Dim ws As Worksheet
    Dim ticker As String

    dateFrom = Worksheets("Parameters").Range("$b$5")
    dateTo = Worksheets("Parameters").Range("$b$6")
    frequency = Worksheets("Parameters").Range("$b$7")
    MyPath = Worksheets("Parameters").Range("$b$8")

    For Each ws In Worksheets
        If ws.Name <> "Parameters" And ws.Name <> "About" Then
            ticker = ws.Name
            MyFileName = ticker & " " & Format(dateFrom, "dd-mm-yyyy") & " - " & Format(dateTo, "dd-mm-yyyy") & " " & frequency
            If Not Right(MyPath, 1) = "\" Then MyPath = MyPath & "\"
            If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv"
            Sheets(ticker).Copy
            With ActiveWorkbook
                .SaveAs Filename:= _
                    MyPath & MyFileName, _
                    FileFormat:=xlCSV, _
                    CreateBackup:=False
                .Close False
            End With
        End If
    Next
End Sub

Sub getCookieCrumb(crumb As String, cookie As String, validCookieCrumb As Boolean)

    Dim i As Integer
    Dim str As String
    Dim crumbStartPos As Long
    Dim crumbEndPos As Long
    Dim objRequest
 
    validCookieCrumb = False
    
    For i = 0 To 5  'ask for a valid crumb 5 times
        Set objRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
        With objRequest
            .Open "GET", "https://finance.yahoo.com/lookup?s=bananas", False
            .setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
            .send
            .waitForResponse (10)
            cookie = Split(.getResponseHeader("Set-Cookie"), ";")(0)
            'crumbStartPos = InStr(1, .ResponseText, """CrumbStore"":{""crumb"":""", vbBinaryCompare) + Len("""CrumbStore"":{""crumb"":""")
            crumbStartPos = InStrRev(.ResponseText, """crumb"":""") + 9
            crumbEndPos = crumbStartPos + 11 'InStr(crumbStartPos, .ResponseText, """", vbBinaryCompare)
            crumb = Mid(.ResponseText, crumbStartPos, crumbEndPos - crumbStartPos)
            'Sheets("Parameters").Range("C30") = crumbStartPos
            'Sheets("Parameters").Range("C31") = crumbEndPos
            'Sheets("Parameters").Range("c32") = crumb
        End With
        
        If Len(crumb) = 11 Then 'a valid crumb is 11 characters long
            validCookieCrumb = True
            Exit For
        End If:
        
'        If i = 5 Then ' no valid crumb
'            validCookieCrumb = False
'        End If
    Next i
    
End Sub

Sub getYahooFinanceData(stockTicker As String, startDate As String, endDate As String, frequency As String, cookie As String, crumb As String)
    Dim resultFromYahoo As String
    Dim objRequest
    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
    Dim tickerURL As String

    'Construct URL
    '***************************************************
    tickerURL = "https://query1.finance.yahoo.com/v7/finance/download/" & stockTicker & _
        "?period1=" & startDate & _
        "&period2=" & endDate & _
        "&interval=" & frequency & "&events=history" & "&crumb=" & crumb
    'Sheets("Parameters").Range("K" & ticker - 1) = tickerURL
    '***************************************************
              
    'Get data from Yahoo
    '***************************************************
    Set objRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
    With objRequest
        .Open "GET", tickerURL, False
        .setRequestHeader "Cookie", cookie
        .send
        .waitForResponse
        resultFromYahoo = .ResponseText
    End With
    '***************************************************
        
    'Parse returned string into an array
    '***************************************************
    nColumns = 6 'number of columns minus 1  (date, open, high, low, close, adj close, volume)
    csv_rows() = Split(resultFromYahoo, Chr(10))
    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
 
    'Write results into worksheet for ticker
    Sheets(stockTicker).Range("A2").Resize(UBound(resultArray, 1) + 1, UBound(resultArray, 2) + 1).Value = resultArray
    '***************************************************
    
End Sub
Code:
Click to expand...


Hello. would it be too much to ask for the excel file with above code modules and the worksheets it refers to.. you have have been so very kind to give the entire code.. I hope you don't mind sharing an xlsm file as well.
 
Upvote 0
reacon84 said:
Just as a follow up, the code has unfortunately stopped working now, I think something has changed in Yahoo Finance?

From what I can see, the source has changed from "dividendRate" but I can't see to what?

Thanks in advance
Click to expand...
VBA Code: 
Private Sub qTest_3()

Dim Data_Output() As Variant, Tickers() As Variant, ws As Worksheet, Last_Row As Long, Z As Long, B As Long, Response_STR As String

Dim URL2 As String, metrics() As Variant, Element As String, Http2 As Object, N As Long, _
doc As Object, foundData As Boolean, firstTableRowElements As Object, additionalTableRowElements As Object, tableRow As Variant

Call clear_data

Const Ticker_Column As String = "B"
Const data_output_column_start As String = "C"

Set ws = ThisWorkbook.Sheets("Main")

With ws
    Last_Row = .Range("A" & .Rows.Count).End(xlUp).Row
    Tickers = .Range(Ticker_Column & 2, Ticker_Column & Last_Row).Value 'Take tickers from column B
End With

metrics = Array("Forward Annual Dividend Rate") ', "dividendYield", "fiveYearAvgDividendYield", "trailingAnnualDividendRate", "exDividendDate")

ReDim Data_Output(1 To UBound(Tickers, 1), 1 To UBound(metrics) + IIf(LBound(metrics) = 0, 1, 0))

Set Http2 = CreateObject("Msxml2.ServerXMLHTTP")

Set doc = CreateObject("htmlfile")

For Z = 1 To UBound(Tickers, 1)

    URL2 = "https://finance.yahoo.com/quote/" & Tickers(Z, 1) & "/key-statistics?p=" & Tickers(Z, 1)
   
    Http2.Open "GET", URL2, False
    Http2.send

    doc.body.innerHTML = Http2.responseText
    
    'Yahoo Finnace is currently using 2 different class names within each table
    Set firstTableRowElements = doc.getElementsByClassName("Bxz(bb) H(36px) BdY Bdc($seperatorColor) ")
    Set additionalTableRowElements = doc.getElementsByClassName("Bxz(bb) H(36px) BdB Bdbc($seperatorColor) ")
                                                                
    B = 1
    
    For N = LBound(metrics) To UBound(metrics)
        
        foundData = False
            
        For Each cc In Array(firstTableRowElements, additionalTableRowElements)
            'Loop class name collections until data found.
            For Each tableRow In cc

                If InStr(1, tableRow.outerText, metrics(N)) = 1 Then
                    Data_Output(Z, B) = tableRow.Children(1).innerText
                    foundData = True
                    Exit For
                End If
                
            Next tableRow
            
            If foundData Then Exit For
            
        Next cc
        
        If Not foundData Then Data_Output(Z, B) = "N/A"
        
        B = B + 1
        
    Next N
     
Next Z

ws.Range(data_output_column_start & 2).Resize(UBound(Data_Output, 1), UBound(Data_Output, 2)).Value = Data_Output

MsgBox "Done"

End Sub
 
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,224,823
Messages
6,181,169
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top