使用 VBA 解析 HTML 内容

Question

目前，我正在从 data.cnbc.com/quotes/sdrl 解析报价表，并将 innerhtml 放入我指定的代码旁边的列中。

所以，我会从 A2 中获取符号，然后将产量数据放入 C2，然后移动到下一个符号。

HTML 看起来像：

<table id="fundamentalsTableOne">
  <tbody>
    <tr scope="row">
        <th scope="row">EPS</th>
        <td>8.06</td>
    </tr>
    <tr scope="row">
        <th scope="row">Market Cap</th>
        <td>5.3B</td>
    </tr>
    <tr scope="row">
        <th scope="row">Shares Out</th>
        <td>492.8M</td>
    </tr>
    <tr scope="row">
        <th scope="row">Price/Earnings</th>
        <td>1.3x</td>
    </tr>
</tbody>
</table>
<table id="fundamentalsTableTwo">
  <tbody>
    <tr scope="row">
        <th scope="row">Revenue (TTM)</th>
        <td>5.0B</td>   
    </tr>
    <tr scope="row">
        <th scope="row">Beta</th>
        <td>1.84</td>
    </tr>
    <tr scope="row">
        <th scope="row">Dividend</th>
        <td>--</td>
    </tr>
    <tr scope="row">
        <th scope="row">Yield</th>
        <td><span class="pos">0.00%</span></td>
    </tr>
  </tbody>
</table>

目前，我有：

Sub getInfoWeb()

Dim cell As Integer
Dim xhr As MSXML2.XMLHTTP60
Dim doc As MSHTML.HTMLDocument
Dim table As MSHTML.HTMLTable
Dim tableCells As MSHTML.IHTMLElementCollection

Set xhr = New MSXML2.XMLHTTP60

For cell = 2 To 5

ticker = Cells(cell, 1).Value

    With xhr

        .Open "GET", "http://data.cnbc.com/quotes/" & ticker, False
        .send

        If .readyState = 4 And .Status = 200 Then
            Set doc = New MSHTML.HTMLDocument
            doc.body.innerHTML = .responseText
        Else
            MsgBox "Error" & vbNewLine & "Ready state: " & .readyState & _
            vbNewLine & "HTTP request status: " & .Status
        End If

    End With

    Set table = doc.getElementById("fundamentalsTableOne")
    Set tableCells = table.getElementsByTagName("td")

    For Each tableCell In tableCells

            Cells(cell, 2).Value = tableCell.NextSibling.innerHTML

    Next tableCell

Next cell

End Sub

但是，我收到“拒绝访问”错误，并且在我的 set tablecells 行中出现运行时 91。这是因为每一行中只有一个元素，并且 tablecells 被设置为一个集合吗？此外，是否由于从 javascript 生成的 HTML 导致“访问被拒绝”错误？我不认为这应该是个问题。

如果有人知道如何使它工作，将不胜感激。谢谢。

Answer 1

下面是一个示例，展示了如何获取所需数据：

GetData "sdrl"

Sub GetData(sSymbol)
    Dim sRespText, arrName, oDict, sResult, sItem
    XmlHttpRequest "GET", "http://data.cnbc.com/quotes/" & sSymbol, "", "", "", sRespText
    ParseToNestedArr "<span data-field=""name"">([\s\S]*?)</span>", sRespText, arrName
    XmlHttpRequest "GET", "http://apps.cnbc.com/company/quote/newindex.asp?symbol=" & sSymbol, "", "", "", sRespText
    ParseToDict "<tr[\s\S]*?><th[\s\S]*?>([\s\S]*?)</th><td>(?:<span[\s\S]*?>)*([\s\S]*?)(?:</span>)*</td></tr>", sRespText, oDict
    sResult = arrName(0)(0) & vbCrLf & vbCrLf
    For Each sItem in oDict.Keys
        sResult = sResult & sItem & " = " & oDict(sItem) & vbCrLf
    Next
    MsgBox sResult
End Sub

Sub ParseToDict(sPattern, sResponse, oList)
    Dim oMatch, arrSMatches
    Set oList = CreateObject("Scripting.Dictionary")
    With CreateObject("VBScript.RegExp")
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = sPattern
        For Each oMatch In .Execute(sResponse)
            oList(oMatch.SubMatches(0)) = oMatch.SubMatches(1)
        Next
    End With
End Sub

Sub ParseToNestedArr(sPattern, sResponse, arrMatches)
    Dim oMatch, arrSMatches, sSubMatch
    arrMatches = Array()
    With CreateObject("VBScript.RegExp")
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = sPattern
        For Each oMatch In .Execute(sResponse)
            arrSMatches = Array()
            For Each sSubMatch in oMatch.SubMatches
                PushItem arrSMatches, sSubMatch
            Next
            PushItem arrMatches, arrSMatches
        Next
    End With
End Sub

Sub PushItem(arrList, varItem)
    ReDim Preserve arrList(UBound(arrList) + 1)
    arrList(UBound(arrList)) = varItem
End Sub

Sub XmlHttpRequest(sMethod, sUrl, arrSetHeaders, sFormData, sRespHeaders, sRespText)
    Dim arrHeader
    With CreateObject("Msxml2.ServerXMLHTTP.3.0")
        .SetOption 2, 13056 ' SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS
        .Open sMethod, sUrl, False
        If IsArray(arrSetHeaders) Then
            For Each arrHeader In arrSetHeaders
                .SetRequestHeader arrHeader(0), arrHeader(1)
            Next
        End If
        .Send sFormData
        sRespHeaders = .GetAllResponseHeaders
        sRespText = .ResponseText
    End With
End Sub

它使用后期绑定，因为最初的目标语言是 VBScript，但如果您愿意，将它们更改为早期绑定并不难。 第二个链接http://apps.cnbc.com/company/quote/newindex.asp?symbol=SDRL你可以在网页内容中找到iframe源。

Answer 2

我只是简要浏览了该站点，我认为您可以在没有浏览器对象的情况下执行此操作。

问题在于，这些网站通常使用 Ajax 之类的东西来动态更新较小的 div，而无需刷新整个页面。新数据通常仍以 html 形式到达（尽管可能已压缩），因此仍可以在 HTMLDocument 中对其进行解析，但它来自对不同 URL 的调用。

特别是对于这个站点，您最初从quotes.cnbc.com 获取，然后在后台悄悄地从data.cnbc.com 获取另一个，最后从apps.cnbc.com 获取您想要的表。如果所有这些都是必要的，您仍然可以使用 http 请求对象完成所有这些操作，如果不需要 cookie，甚至可以跳过前两个，并且前两个中不是由 JS 构建的 post 数据。

我建议你下载像Fiddler 4这样的网络流量监控器。它是免费的，在此类项目中必不可少。

这是第一次有点混乱，所以这里有一个快速入门。打开它并首次致电 CNBC 后，在左侧面板中找到它并突出显示。然后在右上角的面板中单击“检查器”选项卡，然后单击“原始”。这将向您显示您的浏览器发送到 CNBC 的标题和发布数据，这是您想要在 HTTP 请求中复制的内容。在右下角面板中，您可以单击 raw 查看响应标头和正文，以及状态代码、HTML 语法、呈现的 html（不带 css）等...您可以使用这些来确定哪个请求返回您的数据真正想要的，看看它是如何到达的。

我想你会惊讶于你有多接近。