Автор Тема: VBA: Макрос автозамены нескольких фрагментов для Word.  (Прочитано 48 раз)

Оффлайн iamalwaysnear

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

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

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

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

Оффлайн Администратор

  • Administrator
  • Сообщений: 1684
Re: Макрос автозамены для Word
« Ответ #1 : 03 Июль 2019, 15:35 »
Написал вам письмо на почту с заголовком "Письмо с форума". Написал именно на почту, а не на форум.

Оффлайн Администратор

  • Administrator
  • Сообщений: 1684
Макрос
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

Оффлайн Администратор

  • Administrator
  • Сообщений: 1684
Если замена однотипная, то вариант, чтобы было меньше кода.
Вносите изменения в пункты 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

  • Посетитель форума
  • Сообщений: 4
Спасибо большое!!! Макрос работает.


Оффлайн Администратор

  • Administrator
  • Сообщений: 1684
написал вам ещё письмо на почту (с другим содержимым)