如何使用VBA打开Excel存储的URL列表并提取指定对象值保存到表格

前置准备 #

• 所有待爬取的URL放在Excel工作表A列，从A2单元格开始填写，B列留空用于存储提取到的Company值
• 代码采用后期绑定适配所有Excel版本，无需提前引用额外类库

IE内核实现版本（兼容性强，适配动态渲染页面） #

Sub 批量提取Company值()
    Dim ie As Object
    Dim html As Object
    Dim lastRow As Long
    Dim i As Long
    Dim targetElement As Object
    
    ' 初始化IE对象
    Set ie = CreateObject("InternetExplorer.Application")
    ie.Visible = False ' 调试时可改为True显示IE窗口
    ie.Silent = True ' 屏蔽页面弹窗报错
    
    ' 获取A列最后一行有数据的行号
    lastRow = ThisWorkbook.ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
    
    ' 遍历所有URL
    For i = 2 To lastRow
        ' 跳过空行
        If ThisWorkbook.ActiveSheet.Cells(i, "A").Value <> "" Then
            ie.Navigate ThisWorkbook.ActiveSheet.Cells(i, "A").Value
            
            ' 等待页面完全加载
            Do While ie.Busy Or ie.readyState <> 4
                DoEvents
            Loop
            ' 额外等待1秒确保动态内容加载完成
            Application.Wait Now + TimeValue("00:00:01")
            
            Set html = ie.document
            ' 查找ID为Company的元素
            On Error Resume Next
            Set targetElement = html.getElementById("Company")
            On Error GoTo 0
            
            ' 写入结果到B列
            If Not targetElement Is Nothing Then
                ThisWorkbook.ActiveSheet.Cells(i, "B").Value = targetElement.innerText
            Else
                ThisWorkbook.ActiveSheet.Cells(i, "B").Value = "未找到对应元素"
            End If
            
            Set targetElement = Nothing
            Set html = Nothing
        End If
    Next i
    
    ' 释放资源
    ie.Quit
    Set ie = Nothing
    MsgBox "提取完成！"
End Sub

高性能版本（无IE依赖，速度更快） #

采用XMLHTTP直接发送请求，无需启动浏览器，运行速度是IE版本的3-5倍，适合2000条这种大批量数据处理：

Sub 批量提取Company值_XMLHTTP()
    Dim xhr As Object
    Dim html As Object
    Dim lastRow As Long
    Dim i As Long
    Dim targetElement As Object
    
    Set xhr = CreateObject("MSXML2.XMLHTTP.6.0")
    Set html = CreateObject("HTMLFile")
    
    lastRow = ThisWorkbook.ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To lastRow
        If ThisWorkbook.ActiveSheet.Cells(i, "A").Value <> "" Then
            With xhr
                .Open "GET", ThisWorkbook.ActiveSheet.Cells(i, "A").Value, False
                .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/114.0.0.0 Safari/537.36"
                .send
                ' 等待请求完成
                Do While .readyState <> 4
                    DoEvents
                Loop
                
                If .Status = 200 Then
                    html.body.innerHTML = .responseText
                    On Error Resume Next
                    Set targetElement = html.getElementById("Company")
                    On Error GoTo 0
                    
                    If Not targetElement Is Nothing Then
                        ThisWorkbook.ActiveSheet.Cells(i, "B").Value = targetElement.innerText
                    Else
                        ThisWorkbook.ActiveSheet.Cells(i, "B").Value = "未找到对应元素"
                    End If
                Else
                    ThisWorkbook.ActiveSheet.Cells(i, "B").Value = "请求失败，状态码：" & .Status
                End If
            End With
            ' 每次请求间隔0.5秒，避免触发网站反爬机制
            Application.Wait Now + TimeValue("00:00:00") / 2
            Set targetElement = Nothing
        End If
    Next i
    
    Set xhr = Nothing
    Set html = Nothing
    MsgBox "提取完成！"
End Sub

注意事项 #

• 大批量提取建议每跑500条暂停2-3分钟，避免触发站点反爬限制
• 如果页面动态渲染逻辑复杂，优先使用IE内核版本
• 若遇到请求失败的情况，可适当调大请求间隔时间

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