Форум по VBA и MS Office

Sub макрос()

    Dim find_rng As Range, find As find
    Dim rng As Range, i As Long
   
   
    '1. Отключение монитора (может это ускорит макрос и не будет мерцать).
    Application.ScreenUpdating = False
   
    '2. Создание объектов, которые будут искать.
    Set find_rng = ActiveDocument.Range(0, 0)
    Set find = find_rng.find
   
    '3. Настройка поиска.
    find.Format = True
    find.Style = "Стиль1"
    find.Wrap = wdFindStop
   
    '4. Поиск.
    Do While find.Execute = True
   
        '1) Удаление пустых абзацев, которые находятся после найденного фрагмента.
       
        ' Присваиваем имя "rng" найденному фрагменту.
        Set rng = find_rng.Duplicate
        ' Превращение объекта "rng" в точку вставки и установка её после найденого фрагмента.
        rng.Collapse Direction:=wdCollapseEnd
        ' Включение в объект "rng" знаков абзацев, которые находятся после найденного фрагмента.
        rng.MoveEndWhile Cset:=Chr(13)
       
        ' Удаление пустых абзацев в объекте "rng".
        For i = rng.Paragraphs.Count To 1 Step -1
            If rng.Paragraphs(i).Range.Characters.Count = 1 Then
                rng.Paragraphs(i).Range.Delete
            End If
        Next i
       
        '2) Вставка пустого абзаца после найденного фрагмента.
        find_rng.InsertParagraphAfter
       
        '3) Придание вставленному пустому абзацу стиля "Обычный".
            ' Вставленный абзац войдёт в состав "find_rng".
        find_rng.Paragraphs.Last.Style = ActiveDocument.Styles(wdStyleNormal).NameLocal
       
        '4) Превращение рейнджа в точку вставки и установка точки вставки после найденного фрагмента.
        find_rng.Collapse Direction:=wdCollapseEnd
       
    Loop
   
    '5. Вкл. монитора.
    Application.ScreenUpdating = True
   
    '6. Сообщение.
    MsgBox "Готово.", vbInformation
   
End Sub