Excel VBA code - Amend to pick up other tables in different page?

Question

A quick question about the amending of a piece of code to pick up other web page table contents. I had some great guidance on here about how to pick up certain table contents based on the title and it works great - thanks again to 'QHarr' who was so helpful.

The URL I was wanting the table details from was:

https://finance.yahoo.com/quote/AAPL/?p=AAPL

This is the piece of code which took the data I wanted:

Sub GetYahooInfo100()
Dim tickers(), ticker As Long, lastRow As Long, headers()
Dim wsSource As Worksheet, http As clsHTTP, html As HTMLDocument

Application.ScreenUpdating = False

Set wsSource = ThisWorkbook.Worksheets("100")
Set http = New clsHTTP

headers = Array("Ticker", "Previous Close", "Open", "Bid", "Ask", "Day's Range", "52 Week Range", "Volume", "Avg. Volume", "Market Cap", "Beta", "PE Ratio (TTM)", "EPS (TTM)", _
                "Earnings Date", "Forward Dividend & Yield", "Ex-Dividend Date", "1y Target Est")

With wsSource
    lastRow = GetLastRow(wsSource, 1)
    Select Case lastRow
    Case Is < 3
        Exit Sub
    Case 3
        ReDim tickers(1, 1): tickers(1, 1) = .Range("A3").Value
    Case Is > 3
        tickers = .Range("A3:A" & lastRow).Value
    End Select

    ReDim Results(0 To UBound(tickers, 1) - 1)
    Dim i As Long, endPoint As Long
    endPoint = UBound(headers)

    For ticker = LBound(tickers, 1) To UBound(tickers, 1)
        If Not IsEmpty(tickers(ticker, 1)) Then
            Set html = http.GetHTMLDoc("https://finance.yahoo.com/quote/" & tickers(ticker, 1) & "/?p=" & tickers(ticker, 1))
            Results(ticker - 1) = http.GetInfo(html, endPoint)
            On Error Resume Next
            Set html = Nothing
        Else
            Results(ticker) = vbNullString
        End If
    Next

    .Cells(2, 1).Resize(1, UBound(headers) + 1) = headers
    For i = LBound(Results) To UBound(Results)
        .Cells(3 + i, 2).Resize(1, endPoint - 1) = Results(i)
    Next
End With
Application.ScreenUpdating = True
End Sub

With a further piece below:

Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
    GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With

End Function

Like I say one of the members on here was very helpful in identifying how to do that. I have tried in vein to amend the piece of code to pick up another set of data from the statistics page, as follows:

https://finance.yahoo.com/quote/AAPL/key-statistics?p=AAPL

but I must be missing something. Unless my references are incorrect for the tables then I'm at a loss. I am looking to see if I can capture all the data fields in each of the tables, not just one which is where I may be going wrong.

Was hoping someone may be able to assist.

With forward thanks.

user_6241235 · Answer

Try the following:

Option Explicit

Public Sub GetYahooInfo()
    Dim tickers(), ticker As Long, lastRow As Long, headers()
    Dim wsSource As Worksheet, http As Object, html As New HTMLDocument
    headers = Array("Previous Close", "Open", "Bid", "Ask", "Day's Range", "52 Week Range", "Volume", "Avg. Volume", "Market Cap", _
                    "Beta", "PE Ratio (TTM)", "EPS (TTM)", "Earnings Date", "Forward Dividend & Yield", "Ex-Dividend Date", "1y Target Est", _
                    "Market Cap (intraday)", "Enterprise Value", "Trailing P/E", "Forward P/E", "PEG Ratio (5 yr expected)", "Price/Sales (ttm)", _
                    "Price/Book (mrq)", "Enterprise Value/Revenue", "Enterprise Value/EBITDA", "Fiscal Year Ends", "Most Recent Quarter (mrq)", _
                    "Profit Margin", "Operating Margin (ttm)", "Return on Assets (ttm)", "Return on Equity (ttm)", "Revenue (ttm)", "Revenue Per Share (ttm)", _
                    "Quarterly Revenue Growth (yoy)", "Gross Profit (ttm)", "EBITDA", "Net Income Avi to Common (ttm)", "Diluted EPS (ttm)", _
                    "Quarterly Earnings Growth (yoy)", "Total Cash (mrq)", "Total Cash Per Share (mrq)", "Total Debt (mrq)", _
                    "Total Debt/Equity (mrq)", "Current Ratio (mrq)", "Book Value Per Share (mrq)", "Operating Cash Flow (ttm)", _
                    "Levered Free Cash Flow (ttm)", "Beta", "52-Week Change", "S&P500 52-Week Change", "52 Week High", "52 Week Low", _
                    "50-Day Moving Average", "200-Day Moving Average", "Avg Vol (3 month)", "Avg Vol (10 day)", _
                    "Shares Outstanding", "Float", "% Held by Insiders", "% Held by Institutions", "Shares Short (Aug 31, 2018)", _
                    "Short Ratio (Aug 31, 2018)", "Short % of Float (Aug 31, 2018)", "Short % of Shares Outstanding (Aug 31, 2018)", _
                    "Shares Short (prior month Jul 31, 2018)", "Forward Annual Dividend Rate", "Forward Annual Dividend Yield", _
                    "Trailing Annual Dividend Rate", "Trailing Annual Dividend Yield", "5 Year Average Dividend Yield", "Payout Ratio", _
                    "Dividend Date", "Ex-Dividend Date", "Last Split Factor (new per old)", "Last Split Date")
    Application.ScreenUpdating = False

    Set wsSource = ThisWorkbook.Worksheets("Sheet1") '<== Change as appropriate to sheet containing the tickers

    With wsSource
        lastRow = GetLastRow(wsSource, 1)
        Select Case lastRow
        Case Is < 3
            Exit Sub
        Case 3
            ReDim tickers(1, 1): tickers(1, 1) = .Range("A3").Value
        Case Is > 3
            tickers = .Range("A3:A" & lastRow).Value
        End Select

        Dim i As Long, sResponse As String
        Set http = CreateObject("MSXML2.XMLHTTP")

        For ticker = LBound(tickers, 1) To UBound(tickers, 1)
            With Worksheets("Sheet1")
                If Not IsEmpty(tickers(ticker, 1)) Then
                    With http
                        .Open "GET", "https://finance.yahoo.com/quote/" & tickers(ticker, 1) & "/key-statistics?p=" & tickers(ticker, 1), False
                        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
                        .send
                        sResponse = StrConv(.responseBody, vbUnicode)
                    End With

                    sResponse = Mid$(sResponse, InStr(1, sResponse, " 0 Or InStr(tables(i + 1).innerText, "Last Split Date") > 0 Then
                            Exit For
                        End If
                        counter = counter + 1
                    Next
                    Set html = Nothing: Set tables = Nothing
                Else
                    .Cells(2 + ticker, 2) = "N/A"
                End If
            End With
        Next
    End With
    Application.ScreenUpdating = True
End Sub

Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
    With ws
        GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
    End With
End Function

Sample results:

Excel VBA code - Amend to pick up other tables in different page?

1 Answers