Word VBA Макросы: Как сократить макрос множественной замены?

[umbrunt]

Нужно заменить много значений в большом тексте (более 1000 значений).
Менять нужно только первое значение в тексте.
Создал макрос такого вида, но макрос выдаёт ошибку: слишком длинная процедура.
Как можно сократить макрос?

Макрос

Sub Макрос1234567890
'
' Макрос
'
'
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "А1"
        .Replacement.Text = _
            "А1 В1 С1 В1 Е1"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    With Selection
        If .Find.Forward = True Then
            .Collapse Direction:=wdCollapseStart
        Else
            .Collapse Direction:=wdCollapseEnd
        End If
        .Find.Execute Replace:=wdReplaceOne
        If .Find.Forward = True Then
            .Collapse Direction:=wdCollapseEnd
        Else
            .Collapse Direction:=wdCollapseStart
        End If
        .Find.Execute
    End With
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "А2"
        .Replacement.Text = _
            "А2 В2 С2 D2 E2"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    With Selection
        If .Find.Forward = True Then
            .Collapse Direction:=wdCollapseStart
        Else
            .Collapse Direction:=wdCollapseEnd
        End If
        .Find.Execute Replace:=wdReplaceOne
        If .Find.Forward = True Then
            .Collapse Direction:=wdCollapseEnd
        Else
            .Collapse Direction:=wdCollapseStart
        End If
        .Find.Execute
    End With

(.......)

End Sub

[свернуть]

[Администратор]

Поместите эти процедуры в один модуль.
Запускайте процедуру "Макрос".

Макрос

Sub Макрос()

    ' Замена текста. Сюда дописывайте другие пары фраз.
    НайтиИЗаменить "А1", "А1 В1 С1 В1 Е1"
    НайтиИЗаменить "А2", "А2 В2 С2 D2 E2"

End Sub

Private Sub НайтиИЗаменить(ЧтоНайти As String, НовыйТекст As String)

    With ActiveDocument.Range.Find
        .Text = ЧтоНайти
        .Replacement.Text = НовыйТекст
        .Execute Replace:=wdReplaceOne
    End With
   
End Sub

[свернуть]

[umbrunt]

Спасибо.