Sub Test()
Application.ScreenUpdating = False
Dim i As Long
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = True
    .Text = "[^13]{2,}"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
    .Text = "^13D[AO][S ]{1,2}VEREADOR*^13"
    .Replacement.Text = ""
    .Execute
  End With
  Do While .Find.Found
      .Start = .Start + 1
      Do While .Paragraphs.Last.Next.Range.Font.Bold = False And .Paragraphs.Last.Next.Range.End <> ActiveDocument.Range.End
        .MoveEnd wdParagraph, 1
      Loop
      For i = .Paragraphs.Count To 2 Step -1
        If Not .Paragraphs(i).Range.Text Like "Nº #*" Then
          If Not .Paragraphs(i).Range.Text Like "D[AO][S ]*VEREADOR*" Then .Paragraphs(i).Range.Characters.First.Previous = " "
        End If
      Next
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
  With .Find
    .Forward = True
    .Wrap = wdFindContinue
    .MatchWildcards = True
    .Text = "[^13]"
    .Replacement.Text = "^p^p"
    .Execute Replace:=wdReplaceAll
    .Text = "(^13D[AO][S ]{1,2}VEREADOR*)[^13]{1,}"
    .Replacement.Text = "\1^p"
    .Execute Replace:=wdReplaceAll
  End With
End With
With ActiveDocument.Range
  While .Characters.Last.Previous.Text = vbCr
    .Characters.Last.Previous.Text = vbNullString
  Wend
End With
Application.ScreenUpdating = True
End Sub