如何在 VBA 中使用 .querySelectorAll 避免来自 HTML 的重复信息？答案

【问题标题】：How to avoid duplicate information from HTML with .querySelectorAll in VBA?如何在 VBA 中使用 .querySelectorAll 避免来自 HTML 的重复信息？
【发布时间】：2019-06-12 19:07:23
【问题描述】：

我正在尝试从一个网站收集数据，该网站存储有关美国车辆事故的信息。为此，我需要遍历网站上的所有案例并将表格存储在 Excel 工作表中，以便我可以重新格式化这些数据以接收所有列出的事故的 CSV。

我从用户“QHarr”（再次感谢您）那里获得了大部分代码，到目前为止，代码工作正常，并使用 .querySelectorAll("table") 收集所有数据。不幸的是，代码似乎在特定情况下两次获取相同的信息。我认为这样做的原因是某些表嵌套在其他表中，因此嵌套表被复制两次到工作表（有时甚至以不同的格式）。我尝试通过添加检查某些关键字但未成功的 if 条件来解决此问题。

代码如下：

Option Explicit

Public Sub GetTables()
    Dim sResponse As String, html As HTMLDocument, clipboard As Object, ws As Worksheet
    Dim initialLinksURL As String, i As Long, j As Long, newURL As String
    Set ws = ThisWorkbook.Worksheets(1)
    Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    Set html = New HTMLDocument
    initialLinksURL = "https://crashviewer.nhtsa.dot.gov/LegacyCDS/Search"

    'Application.ScreenUpdating = False

    Dim ie As Object, caseLinks As Object
    Set ie = CreateObject("InternetExplorer.Application")
    With ie
        .Visible = False
        .Navigate2 initialLinksURL

        While .Busy Or .readyState < 4: DoEvents: Wend

        .document.getElementById("btnSubmit1").Click

        While .Busy Or .readyState < 4: DoEvents: Wend

        Set caseLinks = .document.querySelectorAll("[href*='CaseID=']")     

        Dim linksAndIds()
        ReDim linksAndIds(1 To caseLinks.Length, 1 To 2)
        For i = 0 To caseLinks.Length - 1
            linksAndIds(i + 1, 1) = caseLinks.Item(i)
            linksAndIds(i + 1, 2) = Replace$(caseLinks.Item(i), "https://crashviewer.nhtsa.dot.gov/nass-cds/CaseForm.aspx?xsl=main.xsl&CaseID=", vbNullString)
        Next

        For i = LBound(linksAndIds, 1) To UBound(linksAndIds, 1)

            newURL = "https://crashviewer.nhtsa.dot.gov/nass-cds/CaseForm.aspx?ViewText&CaseID=" & linksAndIds(i, 2) & "&xsl=textonly.xsl&websrc=false" '"https://crashviewer.nhtsa.dot.gov/nass-cds/CaseForm.aspx?ViewPage&xsl=Case.xsl&tab=Crash&form=CaseForm&baseNode=&vehnum=-1&occnum=-1&pos=-1&pos2=-1&websrc=true&title=Crash%20Overview%20-%20Summary&caseid=" & linksAndIds(i, 2) & "&year=&fullimage=false"
            .Navigate2 newURL

            While .Busy Or .readyState < 4: DoEvents: Wend

            Dim tables As Object

            Set tables = .document.querySelectorAll("table")


            For j = 0 To tables.Length - 1
                clipboard.SetText tables.Item(j).outerHTML


                If Not CBool(InStr(tables.Item(j).outerHTML, "Scene Photos")) And Not CBool(InStr(tables.Item(j).outerHTML, "Image ID: ")) _
                    And Not CBool(InStr(tables.Item(j).outerHTML, "Braint")) _
                    And UBound(Split(tables.Item(j).outerHTML, "subtable")) <= 1 Then       'no images and avoid duplicate tables

                    clipboard.PutInClipboard
                    ws.Cells(LastRow(ws) + 2, 1).PasteSpecial
                End If
            Next
        Next

        .Quit
    End With

    'Application.ScreenUpdating = True

End Sub

'https://www.rondebruin.nl/win/s9/win005.htm

Public Function LastRow(ByVal sh As Worksheet) As Long
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

我正在考虑获取最深的 HTML 元素/子元素，但我不知道如何做到这一点，或者这是否能解决我的问题。

非常感谢。

【问题讨论】：

如何填充结果以及你想从@Noco那里解析什么？
你能提供一个写出重复信息的示例网址吗？
@QHarr ：例如，如果我们查看第一个案例（案例 ID：2004-04-089），代码复制了以标题“测量（以厘米为单位）”开头的表格。此外，表格“车辆 1 乘员 1 - 伤害代码”以两种不同的格式复制。
我去看看。你运行下面的代码是否遇到了同样的问题？
@SIM ：基本上，我想要一个 CSV 文件，它将相同类型的信息分组到列中。例如，如果有一个包含车辆属性（例如质量、尺寸等）的表格，我希望所有案例的信息都列在同一列中，以便数据具有可比性并可以进行评估。这能回答你的问题吗？

标签： html vba web-scraping html-table

【解决方案1】：

我们可以努力改进这一点，但我看不到重复出现在哪里。如果数据出现在跨页面的恒定索引处，您会限制您写出的表，例如，使用包含感兴趣索引的数组

Option Explicit

Public Sub GetTables()
    Dim sResponse As String, html As HTMLDocument, clipboard As Object, ws As Worksheet
    Dim initialLinksURL As String, i As Long, j As Long, newURL As String
    Set ws = ThisWorkbook.Worksheets(1)
    Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    Set html = New HTMLDocument
    initialLinksURL = "https://crashviewer.nhtsa.dot.gov/LegacyCDS/Search"

    'Application.ScreenUpdating = False

    Dim ie As Object, caseLinks As Object
    Set ie = CreateObject("InternetExplorer.Application")
    With ie
        .Visible = True
        .Navigate2 initialLinksURL

        While .Busy Or .readyState < 4: DoEvents: Wend

        .document.getElementById("btnSubmit1").Click

        While .Busy Or .readyState < 4: DoEvents: Wend

        Set caseLinks = .document.querySelectorAll("[href*='CaseID=']")

        Dim linksAndIds()
        ReDim linksAndIds(1 To caseLinks.Length, 1 To 2)
        For i = 0 To caseLinks.Length - 1
            linksAndIds(i + 1, 1) = caseLinks.item(i)
            linksAndIds(i + 1, 2) = Replace$(caseLinks.item(i), "https://crashviewer.nhtsa.dot.gov/nass-cds/CaseForm.aspx?xsl=main.xsl&CaseID=", vbNullString)
        Next

        For i = LBound(linksAndIds, 1) To UBound(linksAndIds, 1)

            newURL = "https://crashviewer.nhtsa.dot.gov/nass-cds/CaseForm.aspx?ViewText&CaseID=" & linksAndIds(i, 2) & "&xsl=textonly.xsl&websrc=false" '"https://crashviewer.nhtsa.dot.gov/nass-cds/CaseForm.aspx?ViewPage&xsl=Case.xsl&tab=Crash&form=CaseForm&baseNode=&vehnum=-1&occnum=-1&pos=-1&pos2=-1&websrc=true&title=Crash%20Overview%20-%20Summary&caseid=" & linksAndIds(i, 2) & "&year=&fullimage=false"
            .Navigate2 newURL

            While .Busy Or .readyState < 4: DoEvents: Wend

            Dim tables As Object

            Set tables = .document.querySelectorAll("table")
            Dim arr()
            arr = Array(0, 4, 5, 6, 7, 8, 9, 10, 11)

            For j = LBound(arr) To UBound(arr)
                clipboard.SetText tables.item(arr(j)).outerHTML
                clipboard.PutInClipboard
                ws.Cells(LastRow(ws) + 2, 1).PasteSpecial

            Next
        Next

        .Quit
    End With

    'Application.ScreenUpdating = True

End Sub

'https://www.rondebruin.nl/win/s9/win005.htm

Public Function LastRow(ByVal sh As Worksheet) As Long
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

调试脚本：

为了帮助调试和复制以及为了便于阅读，修改了以下脚本以将每个案例写到新的工作表中

Option Explicit
Public Sub GetTables()
    Dim html As HTMLDocument, clipboard As Object, ws As Worksheet
    Dim initialLinksURL As String, i As Long, j As Long, newURL As String
    Set ws = ThisWorkbook.Worksheets(1)
    Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    Set html = New HTMLDocument
    initialLinksURL = "https://crashviewer.nhtsa.dot.gov/LegacyCDS/Search"

    Application.ScreenUpdating = False

    Dim ie As Object, caseLinks As Object
    Set ie = CreateObject("InternetExplorer.Application")
    With ie
        .Visible = True
        .Navigate2 initialLinksURL

        While .Busy Or .readyState < 4: DoEvents: Wend

        .document.getElementById("btnSubmit1").Click

        While .Busy Or .readyState < 4: DoEvents: Wend

        Set caseLinks = .document.querySelectorAll("[href*='CaseID=']")

        Dim linksAndIds()
        ReDim linksAndIds(1 To caseLinks.Length, 1 To 2)
        For i = 0 To caseLinks.Length - 1
            linksAndIds(i + 1, 1) = caseLinks.item(i)
            linksAndIds(i + 1, 2) = Replace$(caseLinks.item(i), "https://crashviewer.nhtsa.dot.gov/nass-cds/CaseForm.aspx?xsl=main.xsl&CaseID=", vbNullString)
        Next

        For i = LBound(linksAndIds, 1) To UBound(linksAndIds, 1)

            newURL = "https://crashviewer.nhtsa.dot.gov/nass-cds/CaseForm.aspx?ViewText&CaseID=" & linksAndIds(i, 2) & "&xsl=textonly.xsl&websrc=false" '"https://crashviewer.nhtsa.dot.gov/nass-cds/CaseForm.aspx?ViewPage&xsl=Case.xsl&tab=Crash&form=CaseForm&baseNode=&vehnum=-1&occnum=-1&pos=-1&pos2=-1&websrc=true&title=Crash%20Overview%20-%20Summary&caseid=" & linksAndIds(i, 2) & "&year=&fullimage=false"
            .Navigate2 newURL

            While .Busy Or .readyState < 4: DoEvents: Wend

            Dim tables As Object, arr()

            Set tables = .document.querySelectorAll("table")
            arr = Array(0, 4, 5, 6, 7, 8, 9, 10, 11)
            Set ws = ThisWorkbook.Worksheets.Add
            ws.NAME = linksAndIds(i, 2)

            For j = LBound(arr) To UBound(arr)
                clipboard.SetText tables.item(arr(j)).outerHTML
                clipboard.PutInClipboard
                ws.Cells(LastRow(ws) + 2, 1).PasteSpecial
            Next
        Next
        .Quit
    End With
    Application.ScreenUpdating = True
End Sub

'https://www.rondebruin.nl/win/s9/win005.htm

Public Function LastRow(ByVal sh As Worksheet) As Long
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

【讨论】：

如果我们可以缩小感兴趣的表索引，那么我们可能可以编写一些提供更好输出格式的东西。
再次感谢 QHarr。我尝试了您的代码，并且绝对有可能通过使用数组来停止重复，但是由于 table.length 每种情况都会发生变化，我想我会遗漏信息。
取决于感兴趣的表的索引是否保持不变。实际上，我正在过滤表格。在我正确检查的几个案例中，指数似乎是恒定的，但您可以仔细查看。
指数是恒定的吗？
直到数组的索引 11，这些表似乎在所有情况下都包含相同的信息。之后，为每种情况列出了未定义数量的图像，导致索引中的偏移量，不幸的是，这使我无法获得超过索引 11 的基本信息。我将尝试使用一些关键字来找出个人偏移直到找到另一个模式。