html - 无法将正确的网站数据导入excel

Question

我想通过在第一列输入集合编号，让excel在线查找并填写集合名称、砖块计数等详细信息，来制作我的乐高收藏列表。。。
这是我的代码：

Option Explicit  
Sub BrickLinkDataExtraction()

    Dim x As Integer
    Dim i As Integer
    Dim IE As New InternetExplorer

    For i = 5 To Cells(Rows.Count, 1).End(xlUp).Row

        IE.navigate "https://brickset.com/sets/" & Cells(RowIndex:=i, columnindex:=1).Value
        IE.Visible = False

        Do
            DoEvents
        Loop Until IE.readyState = READYSTATE_COMPLETE 'hier moet ik zeggen "tot rijen vol zijn", zoiets? IsEmpty(Range("i+1" & "A"))

        Dim Doc As HTMLDocument
        Set Doc = IE.document
        Dim NAME As String
        NAME = Trim(Doc.getElementsByTagName("dd")(1).innerText)
        Dim THEME As String
        THEME = Trim(Doc.getElementsByTagName("dd")(4).innerText)
        Dim YEAR As String
        YEAR = Trim(Doc.getElementsByTagName("dd")(6).innerText)
        Dim BRICKS As String
        BRICKS = Trim(Doc.getElementsByTagName("dd")(8).innerText)
        Dim MINIFIGS As String
        MINIFIGS = Trim(Doc.getElementsByTagName("dd")(9).innerText)

        If IsEmpty(Cells(RowIndex:=i, columnindex:=2)) Then
            Cells(RowIndex:=i, columnindex:=2).Value = NAME
        End If

        If IsEmpty(Cells(RowIndex:=i, columnindex:=3)) Then
            Cells(RowIndex:=i, columnindex:=3).Value = BRICKS
        End If

        If IsEmpty(Cells(RowIndex:=i, columnindex:=4)) Then
            Cells(RowIndex:=i, columnindex:=4).Value = MINIFIGS
        End If

        If IsEmpty(Cells(RowIndex:=i, columnindex:=5)) Then
            Cells(RowIndex:=i, columnindex:=5).Value = THEME
        End If

        If IsEmpty(Cells(RowIndex:=i, columnindex:=6)) Then
            Cells(RowIndex:=i, columnindex:=6).Value = YEAR
        End If

    Next

    IE.Quit

    Cells.Columns.AutoFit

End Sub

这样做很好，直到代码到达一个集合，该集合没有相同顺序的标记，或者没有使用迷你图。然后我在我的电子表格里得到了错误的信息。
我怎么能指定我需要下面的“名称”，而不是指定第二，第五。。。?
因此，例如https://brickset.com/sets/10224按预期工作；但是https://brickset.com/sets/10262在miniffig列中输入原始零售价格。
另外，有没有一种方法可以优化代码，使其不需要很长的运行时间？

Answer 1

我将切换到XMLHTTP GET请求以更快地检索您想要的信息。
HTML并不能像您所发现的那样提供一种只选择感兴趣项的好方法。当每页上的项目数不相同时，位置匹配就会失效。
一致的模式是项目名（dt标记）和值（dd标记）成对出现。例如，"Name"附带"Town Hall"；因此，您可以收集一个dt中的nodeList元素，另一个可以收集dd；在第一个检查中，您需要的项目名称存在。项名称列表的长度将与关联值列表的长度匹配，因此您只需要循环项并使用与找到所需项名称的位置相同的索引访问值nodeList。
过程：
我将感兴趣的集合存储在一个数组sets中，我从Sheet1列A中读取该数组。我循环该数组，将当前集合号连接到一个基url常量，以获取乐高集合的实际url。XMLHTTP GET Request针对该url发出。
使用一个helper函数GetHTMLDoc来处理请求并返回带有页面html的HTMLDocument。
我使用另一个助手函数GetItemsInfo，从存储在最近返回的HTMLDocument中的HTML页面检索您想要的各种项目。它创建一个字典，resultsDict，其键是感兴趣的项，即"Name","Theme"等。这些键有一个初始的vbNullstring值，如果在页面上找到该键，字典中该键的值将被页面上找到的值覆盖。
每个页面的结果字典都存储在一个数组results中，稍后我会循环该数组将结果写入页面。
待办事项：
您可以通过一些额外的错误处理来开发这个。例如，当GET请求由于找不到页面而无法返回所需的HTML，或者无法处理起始行和结束行之间A列中的空白单元格时。
有一个免费的SOAP based API你可以探索。我不确定它是否提供了所有可用的项目，从文件的初步浏览。
处理返回字符串中可能不需要的字符，例如James Bond title中的Â，如果不处理，则会出现在写入工作表时。在这种情况下，我使用Replace$(info(i).innerText, Chr$(194), vbNullString)。
CSS SELECTORS:
我使用的事实是，每个dd感兴趣的标记都由dt标记前置，在父dl感兴趣的标记中：

这意味着我可以使用CSS选择器以页面样式为目标，用父标记收集所有dt标记。然后循环返回的dl，根据字典键检查每个节点的nodeList值。如果它们匹配（存在），那么我知道我想要的东西存在于页面上。假设父元素中的每个innerText标记都有一个匹配的dd标记，我知道我想要的值将位于dt中的同一索引中，我可以通过获取所有带有父标记nodeList的dd标记来返回。然后我可以用找到的值覆盖字典值。
我应用CSS选择器dl，返回带有父dl dt标记的dt标记的所有元素。此选择器通过dl的.querySelectorAll方法应用。这将返回一个HTMLDocument，其nodeList可以被遍历以通过索引访问各个节点，从0开始。这是.Length节点列表-它包含每个项目名，例如"titles"等。
CSS查询示例：
类似的CSS查询被用于值，返回一个"Name","Theme"，我称之为nodeList，使用info
VBA:

Option Explicit
Public Sub GetInfo()
    Dim i As Long, html As HTMLDocument, sets(), http As Object, results(), url As String
    Const BASE_URL As String = "https://brickset.com/sets/"
    Application.ScreenUpdating = False

    With ThisWorkbook.Worksheets("Sheet1")
        Dim lastRow As Long: lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        If lastRow < 5 Then
            Exit Sub
        ElseIf lastRow = 5 Then
            ReDim sets(1, 1): sets(1, 1) = .Range("A5").Value
        Else
            sets = .Range("A5:A" & lastRow).Value
        End If

        ReDim results(0 To UBound(sets, 1) - 1) 
        Set http = CreateObject("MSXML2.XMLHTTP")

        For i = LBound(sets, 1) To UBound(sets, 1)
            url = BASE_URL & sets(i, 1)
            Set html = GetHTMLDoc(http, url)
            Set results(i - 1) = GetItemsInfo(html)
        Next

        Dim headers()
        headers = Array("Set", "Name", "Theme", "Year released", "Pieces", "Minifigs")
        .Cells(4, 1).Resize(1, UBound(headers) + 1) = headers

        For i = LBound(results) To UBound(results)
            .Cells(i + 5, 2).Resize(1, results(i).Count) = results(i).Items
        Next
    End With
    Application.ScreenUpdating = True
End Sub

Public Function GetHTMLDoc(ByVal http As Object, ByVal url As String) As HTMLDocument
    Dim html As New HTMLDocument, sResponse As String
    With http
        .Open "GET", url, False
        .send
        sResponse = StrConv(.responseBody, vbUnicode)
    End With       
    html.body.innerHTML = Mid$(sResponse, InStr(1, sResponse, "<!DOCTYPE "))   
    Set GetHTMLDoc = html
End Function

Public Function GetItemsInfo(ByVal html As HTMLDocument) As Object
    Dim titles As Object, info As Object, i As Long
    Dim resultsDict As Object
    Set resultsDict = CreateObject("Scripting.Dictionary")
    resultsDict.Add "Name", vbNullString
    resultsDict.Add "Theme", vbNullString
    resultsDict.Add "Year released", vbNullString
    resultsDict.Add "Pieces", vbNullString
    resultsDict.Add "Minifigs", vbNullString

    With html
        Set titles = .querySelectorAll("dl dt")
        Set info = .querySelectorAll("dl dd")

        For i = 0 To titles.Length - 1
            If resultsDict.Exists(titles(i).innerText) Then
                resultsDict(titles(i).innerText) = Replace$(info(i).innerText, Chr$(194), vbNullString)
            End If
        Next
    End With
    Set GetItemsInfo = resultsDict
End Function

结果：

引用（VBE>工具>引用）：
微软HTML对象库