Форум по VBA, Excel и Word

Word => Макросы в Word => Тема начата: iamalwaysnear от 03 Июль 2019, 15:31

Название: VBA: Макрос автозамены нескольких фрагментов для Word.
Отправлено: iamalwaysnear от 03 Июль 2019, 15:31
В документах с помощью автозамены делаются одни и те же процедуры замены искомых фрагментов:

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

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

Возможно ли создать макрос, который будет применять автозамену всех 8-ми элементов в документе за один клик?
Название: Re: VBA: Макрос автозамены нескольких фрагментов для Word.
Отправлено: Администратор от 03 Июль 2019, 15:40
Макрос
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
Название: Re: VBA: Макрос автозамены нескольких фрагментов для Word.
Отправлено: Администратор от 03 Июль 2019, 15:44
Если замена однотипная, то вариант, чтобы было меньше кода.
Вносите изменения в пункты 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
Название: Re: VBA: Макрос автозамены нескольких фрагментов для Word.
Отправлено: iamalwaysnear от 03 Июль 2019, 17:12
Спасибо большое!!! Макрос работает.