运行2年正常的VBA翻译代码突发报错，断点在Len(cel)>0处

这段用于批量翻译Excel单元格内容的VBA代码已正常运行2年，如今突然返回错误，调试时断点停在语句If Len(cel) > 0 Then处，原代码如下：

Sub TranslateAllCells()
    Dim rng As Range
    Dim translateFrom As String
    Dim translateTo As String
    Dim getParam As String, trans As String, objHTTP As Object, URL As String
    Dim cel As Range
    translateFrom = Range("L4").Value
    translateTo = Range("L5").Value
    lastColumn = ActiveSheet.UsedRange.Column - 1 + ActiveSheet.UsedRange.Columns.Count
    lastRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
    Set rng = Application.Range(Cells(11, 1), Cells(lastRow, lastColumn))
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    For Each cel In rng.Cells
      With cel
        If Len(cel) > 0 Then
          getParam = cel.Value
          URL = "https://translate.google.pl/m?hl=" & translateFrom & "&sl=" & translateFrom & "&tl=" & translateTo & "&ie=UTF-8&prev=_m&q=" & getParam
          objHTTP.Open "GET", URL, False
          objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
          objHTTP.send ("")
          If InStr(objHTTP.responseText, "div dir=""ltr""") > 0 Then
            trans = RegexExecute(objHTTP.responseText, "div[^""]*?""ltr"".*?""t0"".*?>(.+?)</div>")
            cel.Value = Clean(trans)
          Else
            cel.Value = CVErr(xlErrValue)
          End If
        End If
      End With
    Next cel
End Sub

错误原因分析 #

1. 单元格判断逻辑缺陷：cel是Range对象，直接调用Len(cel)会默认读取cel.Value，但如果单元格本身是错误值（如#N/A、#VALUE!），Len函数会直接抛出错误，这是触发断点的直接原因。
2. 谷歌翻译页面结构变更：代码依赖谷歌翻译移动端非官方页面的HTML结构，谷歌会频繁调整页面布局，运行2年后原有的正则匹配规则必然失效，这是长期运行后报错的核心原因。
3. 请求标识过时：代码使用的IE6版本User-Agent过于老旧，会被谷歌反爬机制拦截，导致请求失败，进而引发后续处理错误。

修复方案 #

1. 修复单元格判断的直接错误 #

将If Len(cel) > 0 Then替换为以下逻辑，先跳过错误值单元格，再判断内容长度：

If Not IsError(cel.Value) And Len(Trim(cel.Value)) > 0 Then

2. 适配接口并优化代码 #

针对谷歌页面变更和反爬机制，调整后的完整代码如下：

Sub TranslateAllCells()
    Dim rng As Range
    Dim translateFrom As String, translateTo As String
    Dim getParam As String, trans As String, objHTTP As Object, URL As String
    Dim cel As Range
    Dim lastColumn As Long, lastRow As Long
    
    ' 获取翻译语言参数并验证
    translateFrom = Trim(Range("L4").Value)
    translateTo = Trim(Range("L5").Value)
    If translateFrom = "" Or translateTo = "" Then
        MsgBox "请在L4、L5单元格填写有效语言代码（如en、zh-CN）", vbExclamation
        Exit Sub
    End If
    
    ' 正确获取有效数据范围
    With ActiveSheet.UsedRange
        lastColumn = .Column + .Columns.Count - 1
        lastRow = .Row + .Rows.Count - 1
    End With
    Set rng = ActiveSheet.Range(ActiveSheet.Cells(11, 1), ActiveSheet.Cells(lastRow, lastColumn))
    
    ' 使用更高版本的HTTP组件
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    
    For Each cel In rng.Cells
        With cel
            ' 跳过错误值和空内容单元格
            If Not IsError(.Value) And Len(Trim(.Value)) > 0 Then
                getParam = WorksheetFunction.EncodeURL(Trim(.Value)) ' 对内容进行URL编码
                URL = "https://translate.google.com/m?hl=" & translateFrom & _
                      "&sl=" & translateFrom & "&tl=" & translateTo & _
                      "&ie=UTF-8&oe=UTF-8&q=" & getParam
                
                ' 捕获请求过程中的错误
                On Error Resume Next
                objHTTP.Open "GET", URL, False
                ' 更新为现代浏览器的User-Agent
                objHTTP.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"
                objHTTP.send ""
                
                If Err.Number = 0 Then
                    ' 适配当前谷歌翻译移动端的结果容器规则
                    trans = RegexExecute(objHTTP.responseText, "<div[^>]+class=""result-container"">(.+?)</div>")
                    .Value = IIf(trans <> "", Clean(trans), CVErr(xlErrValue))
                Else
                    .Value = CVErr(xlErrValue)
                    Err.Clear
                End If
                On Error GoTo 0
            End If
        End With
        ' 添加延迟避免触发反爬限制
        Application.Wait Now + TimeValue("00:00:01")
    Next cel
    
    Set objHTTP = Nothing
    MsgBox "翻译完成", vbInformation
End Sub

' 补充RegexExecute函数（若原代码未包含）
Function RegexExecute(text As String, pattern As String) As String
    Dim regEx As Object
    Set regEx = CreateObject("VBScript.RegExp")
    With regEx
        .Global = False
        .IgnoreCase = True
        .pattern = pattern
    End With
    If regEx.test(text) Then
        RegexExecute = regEx.Execute(text)(0).SubMatches(0)
    End If
End Function

' 补充Clean函数（清理HTML字符）
Function Clean(text As String) As String
    text = Replace(text, "<br>", vbCrLf)
    text = Replace(text, "&nbsp;", " ")
    text = Replace(text, "&amp;", "&")
    Clean = text
End Function

3. 长期稳定建议 #

• 优先使用Google Cloud Translation官方API，虽然需要付费，但完全规避页面变更风险，且有官方技术支持。
• 批量翻译时添加固定延迟，避免短时间内大量请求触发谷歌反爬限制。

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