Word VBA中Do While循环未遍历选区所有匹配项问题排查

问题描述 #

尝试在Word文档选区内，查找数组指定词汇并高亮其所在段落，但运行宏后仅高亮每个词汇的首次匹配项，选区中多个匹配项未被处理。

原代码 #

Sub destacaCabeçalhoManual()

Application.ScreenUpdating = False
Dim i As Long, ArrFnd(), ArrFnd1()
    
    If Not (Selection.Type <> wdSelectionIP) Then
   MsgBox "Nenhum texto foi selecionado" & vbNewLine & vbNewLine & "Por favor selecione o texto antes de prosseguir", _
   vbOKOnly & vbExclamation, "Nada selecionado"
   Exit Sub
End If
    
  'para todos os parágrafos que contêm as palavras
ArrFnd = Array("Órgão:", "Valor\(es\):", "Valor:", _
"Convenente:", "Contratante:", "Recorrente(s):", _
"Câmara Municipal:", "Prefeitura Municipal:", "Órgão Público Concessor:", _
"Representado(s):", "Em Julgamento:", "Exercício:", "Assunto:", "Agravante:", "Agravado:", "AGRAVO")
For i = 0 To UBound(ArrFnd)
  With Selection.Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ArrFnd(i)
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
      .MatchCase = True
      .MatchWholeWord = False
      .MatchWildcards = True
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      
      .Execute
    End With
    Do While .Find.Found = True
      '.HighlightColorIndex = wdYellow
      .End = .Sections.Last.Range.End
       .Duplicate.Paragraphs.First.Range.HighlightColorIndex = wdYellow
  .Start = .Duplicate.Paragraphs.First.Range.End
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
    
  End With
Next

End Sub

问题原因 #

• 破坏初始选区边界：在循环中执行.End = .Sections.Last.Range.End，直接将查找范围从用户选定区域扩展到整个节的末尾，导致后续查找脱离原选区。
• 查找起始点逻辑混乱：.Start = .Duplicate.Paragraphs.First.Range.End修改了原选区范围的起始位置，结合扩展后的End值，使得后续查找无法正确遍历选区内的所有匹配项。

修复后的代码 #

Sub destacaCabeçalhoManual()
    Application.ScreenUpdating = False
    Dim i As Long, ArrFnd() As String
    Dim selRange As Range, findRange As Range
    
    ' 检查是否有有效选区
    If Selection.Type = wdSelectionIP Then
        MsgBox "Nenhum texto foi selecionado" & vbNewLine & vbNewLine & "Por favor selecione o texto antes de prosseguir", _
               vbOKOnly + vbExclamation, "Nada selecionado"
        Exit Sub
    End If
    
    ' 待查找的目标词汇数组
    ArrFnd = Array("Órgão:", "Valor\(es\):", "Valor:", _
                   "Convenente:", "Contratante:", "Recorrente(s):", _
                   "Câmara Municipal:", "Prefeitura Municipal:", "Órgão Público Concessor:", _
                   "Representado(s):", "Em Julgamento:", "Exercício:", "Assunto:", "Agravante:", "Agravado:", "AGRAVO")
    
    ' 保存初始选区，避免后续操作修改原选区
    Set selRange = Selection.Range
    
    For i = 0 To UBound(ArrFnd)
        ' 每次查找前重置为初始选区的副本
        Set findRange = selRange.Duplicate
        
        With findRange.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Text = ArrFnd(i)
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindStop ' 到达选区末尾即停止查找
            .Format = False
            .MatchCase = True
            .MatchWholeWord = False
            .MatchWildcards = True
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        
        Do While findRange.Find.Execute
            ' 高亮当前匹配项所在的段落
            findRange.Paragraphs.First.Range.HighlightColorIndex = wdYellow
            ' 将查找起始点设为当前段落末尾，避免重复匹配同一段落
            findRange.Start = findRange.Paragraphs.First.Range.End
            ' 折叠范围到起始点，准备下一次查找
            findRange.Collapse wdCollapseStart
        Loop
    Next i
    
    Application.ScreenUpdating = True
End Sub

修复说明 #

• 锁定初始选区：用selRange存储用户选定的范围，每次查找都基于该范围的副本，确保始终在指定区域内操作。
• 独立查找范围：使用临时变量findRange处理查找逻辑，修改其边界不会影响原选区。
• 正确遍历匹配项：处理完当前段落后，将查找起始点移至段落末尾并折叠，保证能遍历选区内所有符合条件的匹配项。

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