如何用VBA从表格指定网站提取XPath对应数据？

背景 #

需要从多个网站提取指定数据，表格中已记录对应链接和XPath路径。原Google Sheets方案在数据量大时加载卡顿，现需将提取网页标题的VBA代码修改为按XPath提取数据。

示例数据表格 #

修改后的VBA自定义函数 #

Function GetDataByXPath(urlCell As Range, xpathCell As Range)
'功能：根据指定网页链接和XPath提取目标数据
'适配场景：替代Google Sheets方案，解决大数据量加载卡顿问题

Dim url As String
Dim xpath As String
Dim xmlHttp As Object
Dim htmlDoc As Object
Dim targetElement As Object

'读取单元格中的链接与XPath
url = urlCell.Value
xpath = xpathCell.Value

'校验输入非空
If url = "" Or xpath = "" Then
    GetDataByXPath = "链接/XPath不可为空"
    Exit Function
End If

'发起HTTP请求获取网页内容
On Error GoTo RequestError
Set xmlHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
xmlHttp.Open "GET", url, False
xmlHttp.Send

'解析HTML内容
Set htmlDoc = CreateObject("htmlfile")
htmlDoc.body.innerHTML = xmlHttp.ResponseText

'通过XPath定位元素
Set targetElement = htmlDoc.SelectSingleNode(xpath)

'返回提取结果
If Not targetElement Is Nothing Then
    GetDataByXPath = Trim(targetElement.innerText)
Else
    GetDataByXPath = "未匹配到目标元素"
End If

'释放资源
Cleanup:
Set targetElement = Nothing
Set htmlDoc = Nothing
Set xmlHttp = Nothing
Exit Function

'错误处理分支
RequestError:
GetDataByXPath = "请求异常：" & Err.Description
GoTo Cleanup
End Function

使用步骤 #

1. 打开Excel，按下Alt + F11进入VBA编辑器
2. 右键点击当前工作簿，选择「插入」→「模块」
3. 将上述代码粘贴到模块中，保存工作簿为.xlsm格式（启用宏）
4. 在工作表中调用函数：例如在D2单元格输入=GetDataByXPath(A2,B2)，下拉填充即可批量提取

注意事项 #

• 示例表格中的部分XPath存在语法错误（如缺少闭合括号），需修正后才能正常使用
• 部分网站存在反爬策略，若请求失败可尝试添加请求头（例如xmlHttp.setRequestHeader "User-Agent", "Mozilla/5.0"）
• 批量提取时建议添加短延迟，避免因请求频率过高被网站拦截

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