Форум по VBA и MS Office

Sub Макрос()

    Dim sec As Section, rng As Range
    Dim i As Long
   
   
    '1. Отключение монитора.
    Application.ScreenUpdating = False
   
    ' Цикл по всем разделам, кроме первого.
    For i = 2 To ActiveDocument.Sections.Count Step 1
   
        '2. Vba-именование раздела.
        Set sec = ActiveDocument.Sections(i)
       
        '3. Удаление пустых абзацев перед разделом.
        If sec.Range.Paragraphs(1).Previous(2).Range.Text = Chr(13) Then
            ' Vba-именование фрагмента, в котором находится абзац, который находится перед разделом.
            Set rng = sec.Range.Paragraphs(1).Previous(2).Range.Duplicate
            ' Расширение начала фрагмента, включая в него другие пустые абзацы, которые находятся выше.
            rng.MoveStartWhile Cset:=Chr(13), Count:=wdBackward
            ' Один абзац исключаем, т.к. он относится к абзацу с текстом.
            rng.MoveStart Unit:=wdCharacter, Count:=1
            ' Удаление пустых абзацев.
            rng.Delete
        End If
       
        '4. Вставка трёх абзацев после разрыва раздела.
        ' Сначала удаление пустых абзацев.
        If sec.Range.Paragraphs(1).Range.Text = Chr(13) Then
            ' Vba-именование фрагмента, в котором находится первый абзац раздела.
            Set rng = sec.Range.Paragraphs(1).Range.Duplicate
            ' Расширение начала фрагмента, включая в него другие пустые абзацы, которые находятся ниже.
            rng.MoveEndWhile Cset:=Chr(13), Count:=wdForward
            ' Удаление пустых абзацев.
            rng.Delete
        End If
        ' Вставка трёх абзацев.
        sec.Range.Paragraphs(1).Range.InsertBefore Text:=String(3, Chr(13))
       
    Next i
   
    '5. Включение монитора.
    Application.ScreenUpdating = True
   
End Sub