VBA: Макрос автозамены нескольких фрагментов для Word.

[iamalwaysnear]

В документах с помощью автозамены делаются одни и те же процедуры замены искомых фрагментов:

1. Найти: Text1 Заменить на ^pText1^p
2. Найти: Text2 Заменить на ^pText2^p
...
8. Найти: Text8 Заменить на ^pText8^p

^p - знак абзаца

Возможно ли создать макрос, который будет применять автозамену всех 8-ми элементов в документе за один клик?

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

Макрос

Sub Макрос()
   
    ' Отключение монитора. Может это ускорит макрос.
    Application.ScreenUpdating = False
   
    ' Замена 1.
    With ActiveDocument.Range.Find
        .Text = "Text1"
        .Replacement.Text = "^pText1^p"
        .Execute Replace:=wdReplaceAll
    End With
   
    ' Замена 2.
    With ActiveDocument.Range.Find
        .Text = "Text2"
        .Replacement.Text = "^pText2^p"
        .Execute Replace:=wdReplaceAll
    End With
   
    ' Замена 3 и т.д.
   
    ' Включение монитора.
    Application.ScreenUpdating = True
   
    ' Сообщение.
    MsgBox "Готово.", vbInformation

End Sub

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

Если замена однотипная, то вариант, чтобы было меньше кода.
Вносите изменения в пункты 1 и 2.

Вверху модуля вставьте этот текст:
Option Explicit
Option Compare Text
Option Base 1

Макрос

Sub Макрос()

    '1. В скобках укажите количество слов, которое надо заменить.
    Dim arr(2), i As Long
   
   
    ' Отключение монитора. Может это ускорит макрос.
    Application.ScreenUpdating = False
   
    '2. Сюда запишите слова, которые нужно заменить.
    arr(1) = "Text1"
    arr(2) = "Text2"
   
    ' Замена.
    For i = 1 To UBound(arr)
        With ActiveDocument.Range.Find
            .Text = arr(i)
            .Replacement.Text = "^p" & arr(i) & "^p"
            .Execute Replace:=wdReplaceAll
        End With
    Next i
   
    ' Включение монитора.
    Application.ScreenUpdating = True
   
    ' Сообщение.
    MsgBox "Готово.", vbInformation

End Sub

[iamalwaysnear]

Спасибо большое!!! Макрос работает.