VBA Web Scrape按类名类型不匹配错误获取元素

Question

我正在尝试使用以下代码通过 VBA 将 NHL 统计数据中的一些数据提取到 Excel 中，但出现类型不匹配错误。有什么想法吗？

代码：

Private Sub Hawks()

    Dim IE As New InternetExplorer
    Dim element As HTMLAnchorElement
    Dim elements As HTMLElementCollection

    IE.Visible = False
    IE.navigate "https://www.nhl.com/blackhawks/stats"

    Do
    DoEvents
    Loop Until IE.readyState = READYSTATE_COMPLETE

    Dim Doc As HTMLDocument
    Set Doc = IE.document
    Set elements = Doc.getElementsByClassName("name-col__firstName")

    Dim count As Long

    Dim erow As Long
    count = 0

    For Each element In sDD
    If element.className = "name-col__firstName" Then
    erow = Sheet1.Cells(Rows.count, 1).edn(xlUp).Offset(1, 0).Row
    Cells(erow, 1) = HTML.getElementsByTagName("span")(count).innerText
    count = count + 1
    End If
    Next element

End Sub

Answer 1

您的代码：

也许您合并了单独的代码位，但变量的使用不一致。 sDD 我认为应该是 elements，HTML 应该是 Doc。 element 和 elements 的相关变量类型声明应该是：

Dim element As IHTMLSpanElement
Dim elements As IHTMLElementCollection

如果元素是一个具有相同类名的集合，那么你不需要：

If element.className = "name-col__firstName" 

页面上有 40 个与此类匹配的元素，其中一些重复相同的信息，因为您没有限制在单个表格中。

您正在尝试使用与您的类名集合中的相同索引来索引跨度标记集合，但跨度集合实际上是 1354 个元素的长度，并且索引在页面上不对应。

您只想定位感兴趣的表和其中的元素。以后我会告诉你怎么做。

你在这一行也有一个错字：

erow = Sheet1.Cells(Rows.count, 1).edn(xlUp).Offset(1, 0).Row

应该是End(xlUp)。

---

只是名字：

如果您只是在名称信息之后，那么我将使用 descendant CSS combinator 通过其父 div 元素 id 来定位表，然后通过其类属性的值来定位实际名称。这是一种快速的方法，通过关闭屏幕更新来进一步优化代码。

名字都放在一个ID为skater-table的表中。 CSS 选择器是#skater-table。 # 表示 id。在这个父表 id 元素中的名称本身都有一个包含字符串值text 的类属性。这被写为[class*=text] 的 CSS 属性 = 值选择器。 * 表示类名值包含值text。

您可以在此处查看匹配元素的示例：

---

VBA：全名列表。

Option Explicit
Public Sub GetHawksNamesInfo()
    Dim IE As InternetExplorer, playerList As Object, player As Long
    Application.ScreenUpdating = False
    Set IE = New InternetExplorer
    With IE
        .Visible = False
        .navigate "https://www.nhl.com/blackhawks/stats"
        While .Busy Or .readyState < 4: DoEvents: Wend

        Set playerList = IE.document.querySelectorAll("#skater-table [class*=text]")

        With ThisWorkbook.Worksheets("Sheet1")
            For player = 0 To playerList.Length - 1
                .Cells(player + 1, 1) = playerList.item(player).innerText
            Next
        End With
        .Quit
    End With
    Application.ScreenUpdating = True
End Sub

---

整个表：

您可以通过复制到剪贴板，然后使用以下方法粘贴到工作表来抓取整个表格以及玩家照片：

Option Explicit
Public Sub GetInfo()
    Dim IE As InternetExplorer, clipboard As Object
    Application.ScreenUpdating = False
    Set IE = New InternetExplorer
    With IE
        .Visible = False
        .navigate "https://www.nhl.com/blackhawks/stats"
        While .Busy Or .readyState < 4: DoEvents: Wend

        Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        clipboard.SetText .document.querySelector("#skater-table table").outerHTML
        clipboard.PutInClipboard
        ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).PasteSpecial

        .Quit
    End With
    Application.ScreenUpdating = True
End Sub

---

API：

对于统计书呆子来说，真正的金矿是 API。在检查页面的 HTML 时，我发现了这个脚本，其中详细介绍了 API 提供的客户端值。因此，似乎有可能进行了基于 queryString 的 API 调用。用外行的话来说，一组值可以组合成一个字符串，然后发送到 Web 界面，该界面提供包含所有统计数据的响应，在这种情况下，格式称为 JSON。 API 通常是客户端获取数据的好方法，并且比网络抓取更可靠。

我决定监控网络流量，看看是否进行了我可以抓取的 API 调用。巴津加！进行了以下基于 queryString 的 API 调用，该调用返回 JSON 响应。

https://statsapi.web.nhl.com/api/v1/teams/16?hydrate=franchise(roster(season=20182019,person(name,stats(splits=[yearByYear]))))

注意：如果将上述字符串粘贴到 FireFox 浏览器并按 Enter 键，则可以浏览 JSON 响应。

例如，在 FireFox 中向下滚动，您可以找到 Jersey 号码 19，并查看他们的信息：

---

这会暴露大量以 JSON 字符串形式返回的统计信息。这只是其中包含的内容的一瞥（这甚至不是显示的一个玩家的所有信息！）：

XMLHTTP API 调用和 JSON 解析：

您可以避免完全打开浏览器并针对 API 发出非常快的 XMLHTTP request 并在 JSON 响应中获取所有这些信息，然后您可以使用 JSONParser 进行处理。

JSON 中的信息太多，无法向您展示如何解析它们。这只是从响应中解析所有名称的示例（请注意，这是一个完整的季节列表）。从给定的链接下载并导入 JSONConverter.bas 后，您需要转到 VBE > Tools > References > 添加对 Microsoft Scripting Runtime 的引用。

Option Explicit
Public Sub GetInfo()
    Dim strJSON As String, json As Object
    Const URL  As String = "https://statsapi.web.nhl.com/api/v1/teams/16?hydrate=franchise(roster(season=20182019,person(name,stats(splits=[yearByYear]))))"

    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", URL, False
        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        .send
        strJSON = .responseText
    End With
    Set json = JsonConverter.ParseJson(strJSON)("teams")(1)("franchise")("roster")("roster")
    Dim player As Object
    For Each player In json
        Debug.Print player("person")("fullName")
    Next
End Sub

---

编辑：现在在某些情况下，后期绑定剪贴板引用似乎存在问题。这是通用的早期绑定方法，其中 hTable 是目标 HTMLTable 对象。

对于剪贴板早期绑定，请转到 VBE > 工具 > 参考 > Microsoft-Forms 2.0 对象库。

如果您将用户窗体添加到项目中，该库将自动添加。

Dim clipboard As DataObject
Set clipboard = New DataObject
clipboard.SetText hTable.outerHTML
clipboard.PutInClipboard
ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).PasteSpecial

Answer 2

此方法循环您的表的行而不是 Class Collection name-col__firstName。

我已经对此进行了测试，它似乎可以工作。

Option Explicit

Private Sub Hawks()

    Dim IE As New InternetExplorer

    IE.Visible = False
    IE.navigate "https://www.nhl.com/blackhawks/stats"

    With IE
        Do While .Busy or .ReadyState < 4
            DoEvents
        Loop
    End With

    Dim doc As HTMLDocument
    Dim eRow As Long
    Dim htmlTbl As HTMLTable, tblRow As HTMLTableRow
    Set doc = IE.document
    Set htmlTbl = doc.getElementById("skater-table").getElementsByTagName( _
            "table")(0)

    For Each tblRow In htmlTbl.Rows
        If tblRow.RowIndex > 0 Then ' Skipping the table header
            eRow = Sheet1.Cells(Rows.count, 1).End(xlUp).Offset(1, 0).Row
            Cells(eRow, 1) = tblRow.getElementsByTagName("span")(0).innerText
        End If
    Next tblRow

    Rem: You may want to consider adding ie.quit

End Sub