如何使用VBA提取无ID的HTML div元素中的邮箱字符串

问题原因 #

• 点击搜索结果进入详情页后未等待页面加载完成就执行元素抓取，导致获取到的对象为空
• 原遍历逻辑错误，对集合对象直接调用查找方法而非当前遍历的单个元素
• 未正确读取邮箱属性：邮箱存储在a标签的href属性中，前缀为mailto:，而非元素文本内容

修正后完整代码 #

Sub Test1()
    Dim IE As Object
    Dim doc As Object
    Dim a_tags As Object
    Dim a_tag As Object
    Dim email_str As String
    
    Set IE = CreateObject("InternetExplorer.Application")
    IE.Visible = True
    IE.navigate "https://www.bayika.de/de/ingenieursuche/"
    
    ' 等待搜索页加载完成
    Do While IE.Busy Or IE.readyState <> 4
        Application.Wait DateAdd("s", 1, Now)
    Loop
    Set doc = IE.document
    
    ' 输入搜索关键词，测试可直接替换为 "Dipl.-Ing.Univ. Ali Riza Acer"
    Set the_input_elements = doc.getElementsByName("suchwort")
    For Each input_element In the_input_elements
        If input_element.getAttribute("name") = "suchwort" Then
            input_element.Value = ThisWorkbook.Sheets("Sortiert").Range("B2").Value
            Exit For
        End If
    Next input_element
    
    ' 点击搜索按钮
    Set the_input_elements2 = doc.getElementsByTagName("button")
    For Each input_element2 In the_input_elements2
        input_element2.Click
        Exit For
    Next input_element2
    
    ' 等待搜索结果页加载完成
    Do While IE.Busy Or IE.readyState <> 4
        Application.Wait DateAdd("s", 1, Now)
    Loop
    
    ' 点击唯一搜索结果
    Set the_input_elements3 = doc.getElementsByClassName("listEntry listEntryClickable listEntryClickableJS")
    For Each input_element3 In the_input_elements3
        input_element3.Click
        Exit For
    Next input_element3
    
    ' ------------------- 修复后逻辑 -------------------
    ' 等待详情页完全加载
    Do While IE.Busy Or IE.readyState <> 4
        Application.Wait DateAdd("s", 2, Now) ' 适当延长等待时间避免动态内容未加载
    Loop
    
    ' 直接查找所有带mailto前缀的a标签提取邮箱
    Set a_tags = doc.getElementsByTagName("a")
    For Each a_tag In a_tags
        If InStr(1, a_tag.href, "mailto:") > 0 Then
            ' 去掉mailto:前缀只保留邮箱地址
            email_str = Replace(a_tag.href, "mailto:", "")
            ThisWorkbook.Sheets("Sortiert").Range("F2").Value = email_str
            Exit For
        End If
    Next a_tag
    
    ' 可选：关闭IE
    ' IE.Quit
    ' Set IE = Nothing
End Sub

关键修改说明 #

• 所有页面跳转后都增加了IE.readyState <> 4的判断，确保页面完全加载完成再执行后续操作
• 简化了邮箱定位逻辑，无需嵌套查询多层class，直接过滤所有a标签的href属性即可快速定位邮箱
• 提取邮箱时自动去除mailto:前缀，直接写入纯邮箱地址到Excel单元格

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