html - Excel VBA 代码 - 修改以获取不同页面中的其他表格？

Question

关于修改一段代码以获取其他网页表格内容的快速问题。我在这里得到了一些关于如何根据标题选择某些表格内容的很好的指导，而且效果很好——再次感谢 'QHarr'谁帮了大忙。

我想要表格详细信息的 URL 是:

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

这是一段获取我想要的数据的代码:

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

下面还有一段:

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

结束函数

就像我说的，这里的一位成员在确定如何做到这一点方面非常有帮助。我已经尝试修改这段代码，从统计页面中提取另一组数据，如下:

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

但我一定是漏掉了什么。除非我对表格的引用不正确，否则我会不知所措。我正在查看是否可以捕获每个表中的所有数据字段，而不仅仅是我可能出错的地方。

希望有人能提供帮助。

谢谢。

Answer 1

尝试以下操作:

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, "<!DOCTYPE "))   
                    html.body.innerHTML = sResponse

                    Dim tables As Object, destLastRow As Long
                    Dim counter As Long: counter = 2

                    Set tables = html.querySelectorAll("tbody td")             
                    .Cells(2, 2).Resize(1, UBound(headers) + 1) = headers

                    For i = 1 To tables.Length - 1 Step 2
                        .Cells(ticker + 2, counter) = tables(i).innerText
                        If InStr(tables(i).innerText, "Last Split Date") > 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

---

示例结果: