Question

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

enter image description here

所以，我会从A2中获取符号然后将yield数据放入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获取GET，然后在后台静静地浏览您的浏览器从data.cnbc.com获取另一个，最后从apps.cnbc.com获取您想要的表格。如果所有这些都是必要的，您仍然可以使用http请求对象执行所有这些操作，如果不需要cookie，甚至可以跳过前两个，并且前两个中的JS不会构建发布数据。

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

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

我认为你到底有多接近会感到惊讶。

使用VBA解析HTML内容

2 个答案: