Добрый день! Помогите пожалуйста!
Есть поле с номером страницы: {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
Да! Работает! Огромное спасибо! Очень классно все получается!
А можно немного доработать, чтобы добавить "С. ", чтобы получилось так:
С. {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
Спасибо большое за помощь и оперативность! Огромное спасибо!
Уважаемый автор!
А можно еще попросить вариант с поиском не в выделенном фрагменте, а во всем тексте?
Макрос
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
Большое спасибо!
Этот вариант на моем тексте сработал быстро, а вот предыдущий с выделением большой части текста зависал.
На первый взгляд ничего тормозящего нет в первом макросе, не знаю, почему может тормозить. По сути нет разницы между первым и вторым макросом.