Sub Test()
Application.ScreenUpdating = False
Dim i As Long, RngFnd As Range, RngTmp As Range
With ActiveDocument
  Set RngFnd = .Range
  Set RngTmp = .Range
  With .Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Forward = True
      .Wrap = wdFindStop
      .MatchWildcards = True
      .Text = "^13D[ao][s ]{1,2}Vereador*^13"
      .Replacement.Text = ""
      .Execute
    End With
    RngFnd.Start = .Start
    RngTmp.Start = .Start
  End With
  With RngTmp
    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
  End With
  Set RngTmp = RngFnd
  With RngTmp.Find
    .Forward = True
    .Wrap = wdFindStop
    .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
  With .Range
    While .Characters.Last.Previous.Text = vbCr
      .Characters.Last.Previous.Text = vbNullString
    Wend
  End With
End With
Application.ScreenUpdating = True
End Sub