Word Макрос: Внедрить поле с номерами страниц

[Anton]

Добрый день! Помогите пожалуйста!

Есть поле с номером страницы: {PAGE \*Arabic \* MERGEFORMAT }
Это поле мне нужно внедрить в выделенном фрагменте текста слева и справа от сочетания " - № - ", т. е. если в выделенном фрагменте такое сочетание есть, то должно получиться:

  {PAGE \*Arabic \* MERGEFORMAT } - № - {PAGE \*Arabic \* MERGEFORMAT }

Возможно ли автоматизировать процесс?

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

Макрос

Sub Макрос()
   
    Dim find_rng As Range, find As find, SelStart As Long
    Dim rngIns As Range
   
   
    '1. Отключение монитора для ускорения макроса и чтобы не мерцало.
    Application.ScreenUpdating = False
   
    '2. Запоминание начала выделения.
    SelStart = Selection.Range.Start
   
    '3. Создание объектов для поиска.
    Set find_rng = Selection.Range.Duplicate
    find_rng.Collapse Direction:=wdCollapseEnd
    Set find = find_rng.find
   
    '4. Настройка поиска.
    ' Поиск с конца в начало, т.к. будет вставляться текст и конец выделения будет меняться.
    find.Forward = False
    find.Text = " - № - "
    find.Wrap = wdFindStop
   
    '5. Поиск и замена.
    Do While find.Execute = True
   
        ' Если найдено за пределами выделенного фрагмента.
        If find_rng.Start < SelStart Then
            Exit Do
        End If
       
        Set rngIns = find_rng.Duplicate
        rngIns.Collapse Direction:=wdCollapseStart
        ActiveDocument.Fields.Add Range:=rngIns, Type:=wdFieldEmpty, Text:="PAGE  \* Arabic ", PreserveFormatting:=True
       
        Set rngIns = find_rng.Duplicate
        rngIns.Collapse Direction:=wdCollapseEnd
        ActiveDocument.Fields.Add Range:=rngIns, Type:=wdFieldEmpty, Text:="PAGE  \* Arabic ", PreserveFormatting:=True
       
        ' Смещение невидимого курсора влево от найденного фрагмента, чтобы поиск
            ' началася после найденного фрагмента, а не в найденном фрагменте.
        find_rng.Collapse Direction:=wdCollapseStart
       
    Loop
   
    '6. Вкл. монитора.
    Application.ScreenUpdating = True
   
    '7. Сообщение.
    MsgBox "Готово.", vbInformation

End Sub

[свернуть]

[Anton]

Да! Работает! Огромное спасибо! Очень классно все получается!

[Anton]

А можно немного доработать, чтобы добавить "С. ", чтобы получилось так:

С. {PAGE \*Arabic \* MERGEFORMAT } - № - С. {PAGE \*Arabic \* MERGEFORMAT }

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

Макрос

Sub Макрос()
   
    Dim find_rng As Range, find As find, SelStart As Long
    Dim rngIns As Range
   
   
    '1. Отключение монитора для ускорения макроса и чтобы не мерцало.
    Application.ScreenUpdating = False
   
    '2. Запоминание начала выделения.
    SelStart = Selection.Range.Start
   
    '3. Создание объектов для поиска.
    Set find_rng = Selection.Range.Duplicate
    find_rng.Collapse Direction:=wdCollapseEnd
    Set find = find_rng.find
   
    '4. Настройка поиска.
    ' Поиск с конца в начало, т.к. будет вставляться текст и конец выделения будет меняться.
    find.Forward = False
    find.Text = " - № - "
    find.Wrap = wdFindStop
   
    '5. Поиск и замена.
    Do While find.Execute = True
   
        '1) Если найдено за пределами выделенного фрагмента.
        If find_rng.Start < SelStart Then
            Exit Do
        End If
       
        '2) Вставка данных перед найденным фрагментом.
        Set rngIns = find_rng.Duplicate
        rngIns.Collapse Direction:=wdCollapseStart
        ActiveDocument.Fields.Add Range:=rngIns, Type:=wdFieldEmpty, Text:="PAGE  \* Arabic ", PreserveFormatting:=True
        rngIns.Collapse Direction:=wdCollapseStart
        rngIns.Text = "С. "
       
        '3) Вставка данных после найденного фрагмента.
        Set rngIns = find_rng.Duplicate
        rngIns.Collapse Direction:=wdCollapseEnd
        ActiveDocument.Fields.Add Range:=rngIns, Type:=wdFieldEmpty, Text:="PAGE  \* Arabic ", PreserveFormatting:=True
        rngIns.Collapse Direction:=wdCollapseStart
        rngIns.Text = "С. "
       
        '4) Смещение невидимого курсора влево от найденного фрагмента, чтобы поиск
            ' началася после найденного фрагмента, а не в найденном фрагменте.
        find_rng.Collapse Direction:=wdCollapseStart
       
    Loop
   
    '6. Вкл. монитора.
    Application.ScreenUpdating = True
   
    '7. Сообщение.
    MsgBox "Готово.", vbInformation

End Sub

[свернуть]

[Anton]

Спасибо большое за помощь и оперативность! Огромное спасибо!

[Anton]

Уважаемый автор!
А можно еще попросить вариант с поиском не в выделенном фрагменте, а во всем тексте?

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

Макрос

Sub Макрос()
   
    Dim find_rng As Range, find As find
    Dim rngIns As Range
   
   
    '1. Отключение монитора для ускорения макроса и чтобы не мерцало.
    Application.ScreenUpdating = False
   
    '1. Создание объектов для поиска.
    Set find_rng = ActiveDocument.Range(0, 0)
    Set find = find_rng.find
   
    '2. Настройка поиска.
    find.Text = " - № - "
    find.Wrap = wdFindStop
   
    '3. Поиск и замена.
    Do While find.Execute = True
   
        '1) Вставка данных перед найденным фрагментом.
        Set rngIns = find_rng.Duplicate
        rngIns.Collapse Direction:=wdCollapseStart
        ActiveDocument.Fields.Add Range:=rngIns, Type:=wdFieldEmpty, Text:="PAGE  \* Arabic ", PreserveFormatting:=True
        rngIns.Collapse Direction:=wdCollapseStart
        rngIns.Text = "С. "
       
        '2) Вставка данных после найденного фрагмента.
        Set rngIns = find_rng.Duplicate
        rngIns.Collapse Direction:=wdCollapseEnd
        ActiveDocument.Fields.Add Range:=rngIns, Type:=wdFieldEmpty, Text:="PAGE  \* Arabic ", PreserveFormatting:=True
        rngIns.Collapse Direction:=wdCollapseStart
        rngIns.Text = "С. "
       
        '3) Смещение невидимого курсора вправо от найденного фрагмента, чтобы поиск
            ' начался после найденного фрагмента, а не в найденном фрагменте.
        find_rng.Collapse Direction:=wdCollapseEnd
       
    Loop
   
    '4. Сообщение.
    MsgBox "Готово.", vbInformation

End Sub

[свернуть]

[Anton]

Большое спасибо!
Этот вариант на моем тексте сработал быстро, а вот предыдущий с выделением большой части текста зависал.

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

На первый взгляд ничего тормозящего нет в первом макросе, не знаю, почему может тормозить. По сути нет разницы между первым и вторым макросом.