Форум по VBA и MS Office

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