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!
 

Excel Facts

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.
Sort by date Sort by votes
reacon84 said:
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.

View attachment 23532

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!
Click to expand...
Would you like a bit of simplification as well? Is there more to this code that you aren't showing?
 
Upvote 0
MoshiM said:
Would you like a bit of simplification as well? Is there more to this code that you aren't showing?
Click to expand...

Hi Moshi, thanks for the reply!

I would love some simplification please! That is all of the code.
 
Upvote 0
reacon84 said:
Hi Moshi, thanks for the reply!

I would love some simplification please! That is all of the code.
Click to expand...

Try this. Make sure you save beforehand.

Was there a reason for your Do Until Loop ? As it was, it effectively did nothing. Also is my understanding correct that you want the string in-between the first and second term that doesn't intersect with either term.

For example if given the following then you want 1.
"trailingAnnualDividendRate":{"raw":1,"fmt":"1.00"}

If so then my changes will give you that string without having to further split it.

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 Variant, Http2 As New WinHttpRequest

'Set Http2 = CreateObject("Msxml2.ServerXMLHTTP")

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

Call clear_data

Set ws = ThisWorkbook.Sheets("Main")

With ws
    Last_Row = .Range("A" & .Rows.Count).End(xlUp).Row
    Tickers = .Range(Cells(2, 1), Cells(Last_Row, 1)).Value
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"

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 Each Element In metrics
   
        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 Element
   
Next Z

ws.Range(Cells(2, 1), Cells(Last_Row, 1)).Offset(0, 1).Resize(UBound(Data_Output, 1), 5).Value = Data_Output

MsgBox ("Done")

End Sub
 
Upvote 0
My word. You are a wizard.

This has solved all of my problems. I can't believe how helpful this site is.

Incredible! Thank you!!
 
Upvote 0
reacon84 said:
My word. You are a wizard.

This has solved all of my problems. I can't believe how helpful this site is.

Incredible! Thank you!!
Click to expand...
There's one small edit near the top that needs to be made to avoid some potential errors.
Change
VBA Code: 
.Range(Cells(2, 1), Cells(Last_Row, 1)).Value
to
Code: 
.Range(.Cells(2, 1), .Cells(Last_Row, 1)).Value
 
Upvote 0
MoshiM said:
Try this. Make sure you save beforehand.

Was there a reason for your Do Until Loop ? As it was, it effectively did nothing. Also is my understanding correct that you want the string in-between the first and second term that doesn't intersect with either term.

For example if given the following then you want 1.
"trailingAnnualDividendRate":{"raw":1,"fmt":"1.00"}

If so then my changes will give you that string without having to further split it.

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 Variant, Http2 As New WinHttpRequest

'Set Http2 = CreateObject("Msxml2.ServerXMLHTTP")

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

Call clear_data

Set ws = ThisWorkbook.Sheets("Main")

With ws
    Last_Row = .Range("A" & .Rows.Count).End(xlUp).Row
    Tickers = .Range(Cells(2, 1), Cells(Last_Row, 1)).Value
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"

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 Each Element In metrics
  
        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 Element
  
Next Z

ws.Range(Cells(2, 1), Cells(Last_Row, 1)).Offset(0, 1).Resize(UBound(Data_Output, 1), 5).Value = Data_Output

MsgBox ("Done")

End Sub
Click to expand...
Very useful script, thanks. I wanted to add items to the line "metrics = Array" but it kept only giving the first 5. Went down to the line just above MsgBox and adjusted ".Resize(UBound(Data_Output, 1), 6)" form a 5 to a 6 to get an extra item and it worked. How would I get the script to adjust automatically to the number of items in the "metrics = Array" line. Thanks
 
Upvote 0
JARichard74 said:
Very useful script, thanks. I wanted to add items to the line "metrics = Array" but it kept only giving the first 5. Went down to the line just above MsgBox and adjusted ".Resize(UBound(Data_Output, 1), 6)" form a 5 to a 6 to get an extra item and it worked. How would I get the script to adjust automatically to the number of items in the "metrics = Array" line. Thanks
Click to expand...
replace the 5 with UBound(Data_Output, 2) or ubound(metrics)+1
 
Upvote 0
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:
 
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,223,896
Messages
6,175,259
Members
452,626
Latest member
huntinghunter

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