Do While is not making loop into selection in vba word-CodePudding

I am trying to find and highlight the words and its paragraphs from one array. My words are into a selection range. So I've selected a part of my document, but when I run the macro it highlights just the first occurrence of each word, but into the selection there is more than one. Where is my mistake? Here is my code:

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

CodePudding user response：

Try:

Sub destacaCabeçalhoManual()
Application.ScreenUpdating = False
Dim i As Long, ArrFnd(), Rng As Range
'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")
With Selection
  If .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
  Set Rng = .Range
  For i = 0 To UBound(ArrFnd)
    With .Range
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = ArrFnd(i)
        .Replacement.Text = ""
        .Forward = True
        .Format = False
        .Wrap = wdFindStop
        .MatchWildcards = True
      End With
      Do While .Find.Execute
        If Not .InRange(Rng) Then Exit Do
        .Paragraphs.First.Range.HighlightColorIndex = wdYellow
        .Collapse wdCollapseEnd
      Loop
    End With
  Next
End With
Application.ScreenUpdating = True
End Sub