基于Excel A列获取谷歌首条搜索结果URL的VBA代码适配问题

问题根源 #

原代码依赖的谷歌搜索结果容器rso元素ID已被页面结构更新淘汰，且旧版请求头、User-Agent易被反爬机制拦截，导致运行时错误424。

必要的VBA引用 #

打开VBA编辑器（Alt+F11），点击「工具」→「引用」，勾选以下两项：

• Microsoft HTML Object Library
• Microsoft XML, v6.0

更新后的完整代码 #

Sub GetGoogleFirstResultURL()
    Dim url As String, lastRow As Long, i As Long
    Dim xmlHttp As Object, htmlDoc As MSHTML.HTMLDocument
    Dim resultLink As MSHTML.HTMLAnchorElement
    Dim rawURL As String, realURL As String
    Dim startTime As Date, endTime As Date
    
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
    startTime = Time
    Debug.Print "开始时间: " & startTime
    
    ' 初始化XMLHTTP和HTML文档对象
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP.6.0")
    Set htmlDoc = New MSHTML.HTMLDocument
    
    For i = 2 To lastRow
        On Error Resume Next ' 单个搜索失败不中断整体流程
        url = "https://www.google.com/search?q=" & URLEncode(Cells(i, 1).Value) & "&hl=en"
        
        ' 配置请求头，模拟现代浏览器
        xmlHttp.Open "GET", url, False
        xmlHttp.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/118.0.0.0 Safari/537.36"
        xmlHttp.setRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,*/*;q=0.8"
        xmlHttp.setRequestHeader "Accept-Language", "en-US,en;q=0.5"
        xmlHttp.send
        
        ' 加载响应到HTML文档
        htmlDoc.body.innerHTML = xmlHttp.ResponseText
        
        ' 定位首个搜索结果的链接（适配2023年谷歌页面结构）
        Set resultLink = htmlDoc.querySelector("div.g a")
        
        If Not resultLink Is Nothing Then
            rawURL = resultLink.href
            ' 解析谷歌跳转链接，提取真实URL
            If InStr(rawURL, "/url?q=") > 0 Then
                realURL = Mid(rawURL, InStr(rawURL, "/url?q=") + 7)
                realURL = Left(realURL, InStr(realURL, "&") - 1)
                ' URL解码
                realURL = URLDecode(realURL)
                Cells(i, 2).Value = realURL
            Else
                Cells(i, 2).Value = rawURL
            End If
        Else
            Cells(i, 2).Value = "无搜索结果/被拦截"
        End If
        
        ' 延迟1秒，避免触发反爬限制
        Application.Wait Now + TimeValue("00:00:01")
        DoEvents
        On Error GoTo 0
    Next i
    
    endTime = Time
    Debug.Print "结束时间: " & endTime
    Debug.Print "完成！耗时: " & DateDiff("s", startTime, endTime) & "秒"
    MsgBox "完成！耗时: " & DateDiff("s", startTime, endTime) & "秒"
    
    ' 释放对象
    Set xmlHttp = Nothing
    Set htmlDoc = Nothing
    Set resultLink = Nothing
End Sub

' URL编码辅助函数
Function URLEncode(ByVal Text As String) As String
    Dim i As Integer, CharCode As Integer
    Dim Result As String
    
    For i = 1 To Len(Text)
        CharCode = Asc(Mid(Text, i, 1))
        Select Case CharCode
            Case 48 To 57, 65 To 90, 97 To 122, 45, 46, 95, 126
                Result = Result & Mid(Text, i, 1)
            Case Else
                Result = Result & "%" & Hex(CharCode)
        End Select
    Next i
    URLEncode = Result
End Function

' URL解码辅助函数
Function URLDecode(ByVal Text As String) As String
    Dim i As Integer, CharCode As Integer
    Dim Result As String
    
    i = 1
    Do While i <= Len(Text)
        If Mid(Text, i, 1) = "%" Then
            CharCode = "&H" & Mid(Text, i + 1, 2)
            Result = Result & Chr(CharCode)
            i = i + 3
        Else
            Result = Result & Mid(Text, i, 1)
            i = i + 1
        End If
    Loop
    URLDecode = Result
End Function

关键改动说明 #

• 请求头升级：使用现代Chrome的User-Agent，添加标准Accept头，降低被谷歌反爬机制识别拦截的概率
• 元素定位更新：改用querySelector("div.g a")定位首个搜索结果链接，适配2023年谷歌搜索页面的DOM结构
• URL解析逻辑：处理谷歌的跳转链接格式，提取真实目标URL，并新增URL编码/解码函数保证搜索关键词和结果URL的正确性
• 容错与反爬优化：加入错误捕获避免单个搜索失败中断流程，添加1秒延迟减少请求频率，降低触发反爬限制的风险

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