VBA抓取网站企业信息报错及无响应问题求助

第一段代码报错原因分析 #

• 元素选择错误：目标页面中search-item-header是class属性而非id属性，使用getElementById会返回Nothing，后续调用.getElementsByTagName直接触发错误。
• 元素类型声明错误：HTMLUListElement是特定标签类型，目标元素并非<ul>，直接声明会导致类型不匹配，建议改用通用Object或HTMLElement。
• 注释与代码不一致：注释标注找<h1>，但实际代码遍历<h2>，易造成逻辑混淆。

第二段代码无响应原因分析 #

• 反爬拦截：目标网站对直接HTTP请求有反爬限制，MSXML2.XMLHTTP60获取的响应并非正常页面内容，导致getElementsByClassName无法找到目标元素，循环处理无效内容时表现为无响应。
• 变量逻辑混乱：topics和posts变量命名颠倒，易造成逻辑误解，且未添加错误处理，无法排查请求失败问题。

修正后的代码（基于IE引擎，适配目标网站结构） #

以下代码可提取企业名称、地址、电话等信息并写入Excel：

Option Explicit

Const sSiteName = "https://www.thoroughexamination.org/postcode-search/nationwide?page=1"

Private Sub ExtractBusinessInfo()
    Dim IE As Object
    Set IE = CreateObject("InternetExplorer.Application")
    IE.Visible = True ' 调试时可设为True，上线后改为False
    
    IE.Navigate sSiteName
    
    ' 等待页面完全加载（包括动态内容）
    Do While IE.ReadyState <> 4 Or IE.Busy
        DoEvents
    Loop
    
    Dim oHDoc As Object
    Set oHDoc = IE.Document
    
    ' 获取所有搜索结果项（class为search-item的元素）
    Dim searchItems As Object, item As Object
    Dim rowNum As Long
    rowNum = 2 ' 第1行写表头
    
    ' 写入表头
    Cells(1, 1) = "企业名称"
    Cells(1, 2) = "地址"
    Cells(1, 3) = "电话"
    Cells(1, 4) = "传真"
    Cells(1, 5) = "邮箱"
    Cells(1, 6) = "网站"
    
    Set searchItems = oHDoc.getElementsByClassName("search-item")
    
    For Each item In searchItems
        ' 提取企业名称（h2下的a标签）
        On Error Resume Next
        Cells(rowNum, 1) = item.getElementsByClassName("search-item-header")(0).getElementsByTagName("h2")(0).getElementsByTagName("a")(0).innerText
        
        ' 提取地址（class为address的p标签）
        Cells(rowNum, 2) = item.getElementsByClassName("address")(0).innerText
        
        ' 提取联系信息（电话、传真、邮箱、网站）
        Dim contactInfo As Object, infoItem As Object
        Set contactInfo = item.getElementsByClassName("contact-info")(0).getElementsByTagName("li")
        For Each infoItem In contactInfo
            Dim infoText As String
            infoText = infoItem.innerText
            Select Case True
                Case InStr(infoText, "Tel:") > 0
                    Cells(rowNum, 3) = Replace(infoText, "Tel:", "")
                Case InStr(infoText, "Fax:") > 0
                    Cells(rowNum, 4) = Replace(infoText, "Fax:", "")
                Case InStr(infoText, "Email:") > 0
                    Cells(rowNum, 5) = Replace(infoText, "Email:", "")
                Case InStr(infoText, "Website:") > 0
                    Cells(rowNum, 6) = infoItem.getElementsByTagName("a")(0).href
            End Select
        Next infoItem
        
        rowNum = rowNum + 1
        On Error GoTo 0
    Next item
    
    ' 清理资源
    IE.Quit
    Set IE = Nothing
    Set oHDoc = Nothing
    Set searchItems = Nothing
    
    MsgBox "数据提取完成！"
End Sub

使用说明 #

• 确保Excel已启用Microsoft Internet Controls引用（VBA编辑器→工具→引用→勾选该项）。
• 调试时可将IE.Visible设为True，观察页面加载情况；上线后改为False后台运行。
• 若需多页提取，可修改Const sSiteName中的page=1为循环变量，实现分页爬取。

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