Sub A()

Макрос1 "Слон"
Макрос1 "Цирк"
Макрос1 "Верблюд"
....

End Sub

Sub Макрос1(TextToFind As String)
Dim r As Range, s As Range
Application.ScreenUpdating = False
Set r = ActiveDocument.Range
Do
  With r.Find
    .ClearFormatting
    .Text = TextToFind
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    If .Execute Then
      If r.Information(wdWithInTable) Then
        Set s = r.Rows(1).Range
        s.Collapse wdCollapseEnd
        r.Rows(1).Delete
        Set r = ActiveDocument.Range(s.Start)
      Else
        r.Collapse wdCollapseEnd
        Set r = ActiveDocument.Range(r.Start)
      End If
    Else: Exit Do
    End If
  End With
Loop
Application.ScreenUpdating = True
End Sub