使用Excel VBA提取网页数据时如何获取全部搜索结果的对应字段？

核心问题：原有代码仅提取了索引为0的第一条搜索结果，未遍历全部结果节点，且单条数据提取完成后未返回搜索列表页，因此无法获取剩余条目的教区、语言、联系人等信息。
调整后的完整代码如下：

Sub MeethinghouseLocator()
    Dim IE As Object
    Dim Doc As HTMLDocument
    Dim wardNodes As Object
    Dim langNodes As Object
    Dim rowNum As Integer
    Dim i As Long
    
    ' 初始化IE
    Set IE = CreateObject("InternetExplorer.Application")
    IE.navigate Sheets("Sheet1").Range("A1").Value
    IE.Visible = True
    ' 等待页面加载完成
    While IE.Busy Or IE.ReadyState <> 4
        DoEvents
    Wend
    Application.Wait (Now + TimeValue("0:00:01"))
    
    ' 触发搜索
    IE.document.querySelector("button.search-input__execute.button--primary").Click
    ' 等待搜索结果加载
    While IE.Busy Or IE.ReadyState <> 4
        DoEvents
    Wend
    Application.Wait (Now + TimeValue("0:00:02"))
    Set Doc = IE.document
    
    ' 获取所有搜索结果节点
    Set wardNodes = Doc.getElementsByClassName("location-header__name ng-binding")
    If wardNodes.Length = 0 Then
        MsgBox "未查询到匹配结果"
        IE.Quit
        Set IE = Nothing
        Exit Sub
    End If
    
    ' 初始化写入起始行
    rowNum = 6
    
    ' 遍历所有搜索结果
    For i = 0 To wardNodes.Length - 1
        ' 页面回退后DOM会刷新，重新获取节点避免报错
        Set wardNodes = Doc.getElementsByClassName("location-header__name ng-binding")
        Set langNodes = Doc.getElementsByClassName("location-header__language ng-binding ng-scope")
        
        ' 提取教区名称
        Sheets("Sheet1").Range("D" & rowNum).Value = Trim(wardNodes(i).innerText)
        ' 提取使用语言
        If i < langNodes.Length Then
            Sheets("Sheet1").Range("E" & rowNum).Value = Trim(langNodes(i).innerText)
        End If
        
        ' 点击进入详情页
        wardNodes(i).Click
        ' 等待详情页加载
        While IE.Busy Or IE.ReadyState <> 4
            DoEvents
        Wend
        Application.Wait (Now + TimeValue("0:00:01"))
        
        ' 提取联系人原始信息
        Dim contactRaw As String
        On Error Resume Next ' 部分结果可能无联系人信息，避免报错终止
        contactRaw = Trim(Doc.getElementsByClassName("maps-card__group maps-card__group--inline ng-scope")(2).innerText)
        Sheets("Sheet1").Range("H" & rowNum).Value = contactRaw
        Err.Clear
        ' 提取联系电话
        Dim phoneStr As String
        phoneStr = Trim(Doc.getElementsByClassName("phone ng-binding")(0).innerText)
        Sheets("Sheet1").Range("G" & rowNum).Value = phoneStr
        On Error GoTo 0
        
        ' 写入联系人提取公式
        Sheets("Sheet1").Range("F" & rowNum).FormulaR1C1 = _
            "=LEFT(RIGHT(RC[2],LEN(RC[2])-FIND(CHAR(10),RC[2])-3),FIND(RIGHT(RIGHT(RC[2],LEN(RC[2])-FIND(CHAR(10),RC[2])-3),LEN(RIGHT(RC[2],LEN(RC[2])-FIND(CHAR(10),RC[2])-3))-FIND(CHAR(10),RIGHT(RC[2],LEN(RC[2])-FIND(CHAR(10),RC[2])-3))),RIGHT(RC[2],LEN(RC[2])-FIND(CHAR(10),RC[2])-3))-1)"
        
        ' 返回搜索结果列表页
        IE.GoBack
        ' 等待列表页加载
        While IE.Busy Or IE.ReadyState <> 4
            DoEvents
        Wend
        Application.Wait (Now + TimeValue("0:00:01"))
        
        ' 行号偏移，下一条结果写入下一行
        rowNum = rowNum + 1
    Next i
    
    ' 清理资源
    IE.Quit
    Set IE = Nothing
    Set Doc = Nothing
    MsgBox "全部数据提取完成，共提取" & wardNodes.Length & "条结果"
End Sub

注意事项 #

• 运行前请在VBA编辑器的「工具-引用」中勾选「Microsoft HTML Object Library」和「Microsoft Internet Controls」，避免类型报错
• 若网站更新元素类名，对应修改getElementsByClassName内的参数即可
• 代码增加了异常捕获逻辑，部分无联系人或电话的结果不会导致程序终止

内容的提问来源于stack exchange，提问作者Jared