Word VBA Макросы: Удалить пустые абзацы между стилями

[Anton]

Добрый день!
Помогите пожалуйста с помощью макроса удалить пустые абзацы между абзацами с разными стилями. Например, один абзац имеет стиль "Обычный", а следующий абзац - "Заголовок1". Между ними надо удалить все пустые строки (пустые абзацы и абзацы с пробелами). Пример приложил.


[вложение удалено администратором]

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

Этот макрос удаляет пустые абзацы между абзацами с любыми стилями:

Макрос 1

Sub Макрос()

    Dim find_rng As Range, find As find
    Dim rng As Range
   
   
    '1. Откл. монитора.
    Application.ScreenUpdating = False
   
    '2. Создание объектов, которые будут искать.
    Set find_rng = ActiveDocument.Range(ActiveDocument.Range.End - 1, ActiveDocument.Range.End - 1)
    Set find = find_rng.find
   
    '3. Настройка поиска.
    find.text = "^13{2;}"
    find.MatchWildcards = True
    ' Поиск с конца файла в начало.
    find.Forward = False
    find.Wrap = wdFindStop
   
    '4. Поиск.
    Do While find.Execute = True
   
        '1) Присваиваем имя "rng" найденному фрагменту.
        Set rng = find_rng.Duplicate
       
        '2) Переставляем невидимый курсор в начало найденного, чтобы
            ' потом продолжить поиск от найденного и до начала файла.
        find_rng.Collapse Direction:=wdCollapseStart
       
        '3) Сравниваем стиль первого абзаца в найденном фрагменте и стиль
            ' абзаца, который находится после найденного фрагмента.
        If rng.Paragraphs(1).Style <> rng.Paragraphs.Last.Next.Style Then
            '4) Первый знак абзаца находится в абзаце с текстом, поэтому
                ' нужно изменить фрагмент.
            rng.MoveStart Unit:=wdCharacter, Count:=1
            '5) Удаление пустых абзацев.
            rng.Delete
        End If
       
    Loop
   
    '5. Вкл. монитора.
    Application.ScreenUpdating = True
   
    '6. Сообщение.
    MsgBox "Готово.", vbInformation
   
End Sub

[свернуть]

Этот макрос удаляет пустые абзацы между двумя стилями, который указаны в макросе, в пункте 2:

Макрос 2

Sub Макрос()

    Dim find_rng As Range, find As find
    Dim rng As Range, style1 As String, style2 As String
   
   
    '1. Откл. монитора.
    Application.ScreenUpdating = False
   
    '2. Здесь укажите имена стилей.
    style1 = "Обычный"
    style2 = "Заголовок 1"
   
    '3. Создание объектов, которые будут искать.
    Set find_rng = ActiveDocument.Range(ActiveDocument.Range.End - 1, ActiveDocument.Range.End - 1)
    Set find = find_rng.find
   
    '4. Настройка поиска.
    find.Text = "^13{2;}"
    find.MatchWildcards = True
    ' Поиск с конца файла в начало.
    find.Forward = False
    find.Wrap = wdFindStop
   
    '5. Поиск.
    Do While find.Execute = True
   
        '1) Присваиваем имя "rng" найденному фрагменту.
        Set rng = find_rng.Duplicate
       
        '2) Переставляем невидимый курсор в начало найденного, чтобы
            ' потом продолжить поиск от найденного и до начала файла.
        find_rng.Collapse Direction:=wdCollapseStart
       
        '3) Смотрим стиль первого абзаца в найденном фрагменте.
        ' Если это нужный стиль.
        If rng.Paragraphs(1).Style = style1 Then
            '4) Смотрим абзац после найденного фрагмента.
            ' Если это нужный стиль.
            If rng.Paragraphs.Last.Next.Style = style2 Then
                '5) Первый знак абзаца находится в абзаце с текстом, поэтому
                    ' нужно изменить фрагмент.
                rng.MoveStart Unit:=wdCharacter, Count:=1
                '6) Удаление пустых абзацев.
                rng.Delete
            End If
        End If
       
    Loop
   
    '6. Вкл. монитора.
    Application.ScreenUpdating = True
   
    '7. Сообщение.
    MsgBox "Готово.", vbInformation
   
End Sub

[свернуть]

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

Макросы не учитывают пустые абзацы с пробелами.
Но может быть обработать такие абзацы по всему файлу до запуска этих двух макросов?? А потом уже использовать эти макросы.

Пробелы в пустых абзацах можно так удалить во всём файле:

Макрос

Sub Макрос()
    With ActiveDocument.Range.find
        .Text = "(^32{1;})(^13)"
        .Replacement.Text = "\2"
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
    End With
End Sub

[свернуть]

[Anton]

Могу поинтересоваться в целях саморазвития, почему область поиска задается именно так?

'3. Создание объектов, которые будут искать.
    Set find_rng = ActiveDocument.Range(ActiveDocument.Range.End - 1, ActiveDocument.Range.End - 1)

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

Цитата:
Могу поинтересоваться в целях саморазвития

Форум для этого и создан, чтобы интересоваться в целях самообразования. А вы для чего думали создан форум? Чтобы бесплатно делать кому-то макросы?

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

Обсуждение кода:
'3. Создание объектов, которые будут искать.
    Set find_rng = ActiveDocument.Range(ActiveDocument.Range.End - 1, ActiveDocument.Range.End - 1)

Этот код:
ActiveDocument.Range(ActiveDocument.Range.End - 1, ActiveDocument.Range.End - 1)

аналогичен тому, как поставить текстовый курсор в конец файла.

Этот код:
Set find_rng

присваивает имя фрагменту. В нашем случае фрагмент в виде невидимого текстового курсора, который находится в конце файла.

В ворде аналогичный поиск, когда вы не выделяете ничего и ищете. У вас так же ничего не выделено, а просто где-то мигает текстовый курсор. При этом поиск происходит по всему файлу.

[Anton]

Большое спасибо!
Насчет смысла форума полностью согласен! Уже многому научился!