VBA宏循环异常：仅执行第一行后停滞，请求排查解决

问题现象 #

编写的ClearWordBoldStyle宏卡在循环中，仅执行完第一行的查找加粗操作后就不再继续处理后续行的内容。

原代码 #

Sub ClearWordBoldStyle()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim doc As Object ' Word.Document
    Dim wordApp As Object ' Word.Application
    Dim rng As Object ' Word.Range
    Dim lastRowA As Long
    Dim searchString As String
    Dim i As Long

    ' Set the workbook and worksheet
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Sheet1") ' Replace "Sheet1" with the actual sheet name

    On Error Resume Next
    ' Try to get the existing Word application
    Set wordApp = GetObject(, "Word.Application")
    On Error GoTo 0

    If wordApp Is Nothing Then
        ' If Word is not already running, create a new instance
        On Error Resume Next
        Set wordApp = CreateObject("Word.Application")
        On Error GoTo 0
    End If

    If wordApp Is Nothing Then
        MsgBox "Microsoft Word is not installed or accessible.", vbExclamation
        Exit Sub
    End If

    wordApp.Visible = False ' Set to True if you want to see the Word application during execution

    ' Open the Word document (Replace "C:\Path\to\Your\Document.docx" with the actual path)
    Set doc = wordApp.Documents.Open("C:\Path\to\Your\Document.docx")

    ' Find the last row in column A
    lastRowA = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' Copy entire range from Column A to Column B
    ws.Range("B1:B" & lastRowA).Value = ws.Range("A1:A" & lastRowA).Value

    ' Find all instances of the string in the Word document for each value in Column A
    For i = 1 To lastRowA
        ' Get the string from column A for each row
        searchString = ws.Cells(i, "A").Value

        Set rng = doc.Content
        With rng.Find
            .ClearFormatting
            .Text = searchString
            .Forward = True
            .Wrap = 1 ' wdFindStop (Stop searching at the end of the range)
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False

            ' Select and apply bold style for each instance found
            Do While .Execute
                rng.Font.Bold = True
            Loop
        End With
    Next i

    ' Close the Word document
    doc.Close SaveChanges:=False

    ' Quit the Word application
    wordApp.Quit

    ' Clean up the objects
    Set doc = Nothing
    Set wordApp = Nothing
    Set wb = Nothing
    Set ws = Nothing

    MsgBox "Task completed.", vbInformation
End Sub

问题根源 #

1. 死循环触发原因：在Do While .Execute循环中，每次找到匹配内容后没有调整查找范围的起始位置。rng始终指向当前匹配的文本，下一次.Execute会再次找到同一个内容，导致无限循环，宏无法进入下一行的处理。
2. 潜在隐患：On Error Resume Next可能掩盖了文档路径错误、单元格空值等问题，导致无法定位其他异常。

修复方案 #

关键修改点 #

• 在每次设置完加粗格式后，调用rng.Collapse Direction:=2（对应Word常量wdCollapseEnd），将查找范围的起始位置移到当前匹配内容的末尾，确保下一次查找从新位置开始。
• 添加空值检查，避免对空字符串进行无效查找。
• 优化错误处理，仅在必要位置使用On Error Resume Next，并明确处理异常。

修复后的代码 #

Sub ClearWordBoldStyle()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim doc As Object ' Word.Document
    Dim wordApp As Object ' Word.Application
    Dim rng As Object ' Word.Range
    Dim lastRowA As Long
    Dim searchString As String
    Dim i As Long

    ' 设置工作簿和工作表
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Sheet1") ' 替换为实际工作表名称

    ' 尝试获取已运行的Word实例
    On Error Resume Next
    Set wordApp = GetObject(, "Word.Application")
    On Error GoTo 0

    If wordApp Is Nothing Then
        ' 未找到则新建Word实例
        On Error Resume Next
        Set wordApp = CreateObject("Word.Application")
        On Error GoTo 0
    End If

    If wordApp Is Nothing Then
        MsgBox "Microsoft Word未安装或无法访问。", vbExclamation
        Exit Sub
    End If

    wordApp.Visible = False ' 如需查看Word运行过程，设为True

    ' 打开Word文档（替换为实际文档路径）
    On Error Resume Next
    Set doc = wordApp.Documents.Open("C:\Path\to\Your\Document.docx")
    On Error GoTo 0
    If doc Is Nothing Then
        MsgBox "无法打开指定的Word文档，请检查路径是否正确。", vbCritical
        wordApp.Quit
        Set wordApp = Nothing
        Exit Sub
    End If

    ' 获取A列最后一行行号
    lastRowA = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' 将A列内容复制到B列
    ws.Range("B1:B" & lastRowA).Value = ws.Range("A1:A" & lastRowA).Value

    ' 遍历A列每个单元格，在Word文档中查找并加粗匹配内容
    For i = 1 To lastRowA
        searchString = Trim(ws.Cells(i, "A").Value)
        ' 跳过空字符串
        If searchString = "" Then GoTo NextRow

        Set rng = doc.Content
        With rng.Find
            .ClearFormatting
            .Text = searchString
            .Forward = True
            .Wrap = 1 ' wdFindStop：到文档末尾停止查找
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False

            ' 查找并处理所有匹配项
            Do While .Execute
                rng.Font.Bold = True
                ' 将查找范围折叠到当前匹配项末尾，避免重复匹配
                rng.Collapse Direction:=2 ' wdCollapseEnd
            Loop
        End With
NextRow:
    Next i

    ' 关闭文档（不保存）
    doc.Close SaveChanges:=False

    ' 退出Word应用
    wordApp.Quit

    ' 释放对象
    Set doc = Nothing
    Set wordApp = Nothing
    Set ws = Nothing
    Set wb = Nothing

    MsgBox "任务完成。", vbInformation
End Sub

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