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

R

reacon84

New Member
Joined
Sep 13, 2016
Messages
15
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!
 

Some videos you may like

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.
M

MoshiM

Active Member
Joined
Jan 31, 2018
Messages
371
Office Version
  1. 2016
Platform
  1. Windows
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?
 
R

reacon84

New Member
Joined
Sep 13, 2016
Messages
15
Office Version
  1. 2016
Platform
  1. Windows
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.
 
M

MoshiM

Active Member
Joined
Jan 31, 2018
Messages
371
Office Version
  1. 2016
Platform
  1. Windows
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
 
R

reacon84

New Member
Joined
Sep 13, 2016
Messages
15
Office Version
  1. 2016
Platform
  1. Windows
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!!
 
M

MoshiM

Active Member
Joined
Jan 31, 2018
Messages
371
Office Version
  1. 2016
Platform
  1. Windows
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
 
You must log in or register to reply here.

Watch MrExcel Video

Excel Pick From Dropdown List - 2327

Forum statistics

Threads
1,127,756
Messages
5,626,678
Members
416,200
Latest member
Pulsar3000

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
Top