VBA网页爬虫抓取可点击链接名称及按标题新建页签代码调试求助

• 对象赋值语法错误：li_single 声明为Object对象类型，VBA中给对象赋值必须使用Set关键字，原代码直接赋值会触发运行时错误，导致程序提前终止无输出。
• 元素遍历逻辑错误：原代码遍历li_all（class为icon_holder的元素集合）时，固定取第一个元素li_all(0)下的li标签，若第一个icon_holder元素下的li数量小于li_all的长度，会触发下标越界错误，也无法拿到所有目标元素。
• 页面等待逻辑不完善：仅判断IE.ReadyState无法完全确保页面静态资源、DOM渲染完成，还需同时判断IE.Busy状态为False，避免提前获取DOM导致元素为空。
• 缺少异常捕获机制：页面加载失败、目标元素不存在时没有容错处理，程序直接崩溃无输出。

前置准备 #

打开VBA编辑器，点击「工具」-「引用」，勾选以下两个库：

• Microsoft Internet Controls
• Microsoft HTML Object Library

完整可运行代码 #

Option Explicit

Sub Teams()
    Dim IE As SHDocVw.InternetExplorer
    Dim HTMLdoc As MSHTML.HTMLDocument
    Dim li_all As MSHTML.IHTMLElementCollection
    Dim li_list As MSHTML.IHTMLElementCollection
    Dim li_single As MSHTML.HTMLLIElement
    Dim i As Long
    Dim nameArr() As String
    Dim ws As Worksheet
    Dim nameExists As Boolean
    
    ' 初始化IE对象
    Set IE = New SHDocVw.InternetExplorer
    On Error GoTo ErrHandler ' 加异常捕获
    
    With IE
        .Visible = False
        .Navigate "https://www.examplexyz.de/" ' 替换为实际目标网址
        ' 完善页面等待逻辑
        Do While .ReadyState <> READYSTATE_COMPLETE Or .Busy
            DoEvents ' 防止程序卡死
        Loop
        ' 可选：如果页面有异步渲染内容，可适当增加等待时间
        Application.Wait (Now + TimeValue("0:00:03"))
        
        Set HTMLdoc = .Document
    End With
    
    ' 获取所有icon_holder下的li元素
    Set li_all = HTMLdoc.getElementsByClassName("icon_holder")
    If li_all.Length = 0 Then
        Debug.Print "未找到class为icon_holder的元素"
        GoTo Cleanup
    End If
    
    ' 先收集所有目标名称到数组
    ReDim nameArr(1 To 1000) ' 预开空间，后续再缩容
    i = 1
    For Each li_single In li_all
        Set li_list = li_single.getElementsByTagName("li")
        If li_list.Length > 0 Then
            nameArr(i) = li_list(0).innerText
            Debug.Print nameArr(i)
            i = i + 1
        End If
    Next
    If i = 1 Then
        Debug.Print "未找到任何li元素下的名称"
        GoTo Cleanup
    End If
    ReDim Preserve nameArr(1 To i - 1) ' 缩容到实际长度
    
    ' 第二步：为每个名称新建工作表
    For i = LBound(nameArr) To UBound(nameArr)
        ' 先判断工作表是否已存在，避免重复新建报错
        nameExists = False
        For Each ws In ThisWorkbook.Worksheets
            If ws.Name = nameArr(i) Then
                nameExists = True
                Exit For
            End If
        Next
        If Not nameExists Then
            Set ws = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            ws.Name = nameArr(i)
        End If
    Next
    
    MsgBox "操作完成，共抓取" & UBound(nameArr) & "个名称"
    
Cleanup:
    ' 释放资源，避免IE进程残留后台
    IE.Quit
    Set IE = Nothing
    Set HTMLdoc = Nothing
    Set li_all = Nothing
    Set li_list = Nothing
    Set li_single = Nothing
    Set ws = Nothing
    Exit Sub
    
ErrHandler:
    Debug.Print "运行错误：" & Err.Number & "，错误描述：" & Err.Description
    GoTo Cleanup
End Sub

优化点说明 #

• 修正了元素遍历逻辑，遍历每个icon_holder元素下的li标签，确保拿到所有目标名称
• 完善了页面等待逻辑，增加IE.Busy判断和DoEvents，避免程序卡死
• 增加了完整的异常捕获和资源释放逻辑，避免IE进程残留后台
• 先把所有名称收集到数组再统一处理工作表，减少Excel交互次数，提升运行效率
• 增加了工作表重名判断，避免重复新建同名工作表报错

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