Word Макрос: Изменить размер шрифта (оформления) по заголовку и разрывам

[Anton]

Добрый день!
Помогите пожалуйста с таким макросом.
У меня есть текст, везде шрифт размер 12. Но библиографический список должен быть размером 11. Можно ли написать макрос, который весь текст, заключенный между фразой "Библиографический список" и разрывом (страницы или раздела) автоматически приведет к размеру шрифта 11? И, если можно, этот же текст залить заливкой абзаца, например, светло-лиловым цветом. Саму фразу "Библиографический список" изменять не нужно.

Пример приложил, в нем текст, который должен быть размером 11, для примера выделен желтым.

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

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

Макрос

Sub макрос()

    Dim rng As Range
   
   
    '1. Поиск заголовка и разрыва.
    With ActiveDocument.Range.find
        .text = "Библиографический список" & Chr(13) & "*" & Chr(12)
        .MatchWildcards = True
        If .Execute = True Then
            Set rng = .Parent
            rng.MoveStart Unit:=wdParagraph, Count:=1
            rng.MoveEndWhile Cset:=Chr(12), Count:=wdBackward
        End If
    End With
   
    '2. Если нет разрыва, то работа до конца файла.
    If rng Is Nothing Then
        With ActiveDocument.Range.find
            .text = "Библиографический список" & Chr(13)
            If .Execute = True Then
                Set rng = .Parent
                rng.Expand Unit:=wdStory
                rng.MoveStart Unit:=wdParagraph, Count:=1
            End If
        End With
    End If
   
    '3. Если не найден заголовок.
    If rng Is Nothing Then
        MsgBox "Не найден заголовок библиосписка", vbExclamation
        Exit Sub
    End If
   
    '4. Отключение монитора (может это ускорит макрос и не будет мерцать).
    Application.ScreenUpdating = False
   
    '5. Изменение оформления библиосписка.
    rng.Font.Size = 11
    rng.Shading.BackgroundPatternColor = -687800474
   
    '6. Включение монитора.
    Application.ScreenUpdating = True

End Sub

[свернуть]

[Anton]

Спасибо!
Только макрос выделил первый список, дальше не стал. А дальше тоже нужно.
Пример с двумя приложил.

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

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

Макрос

Sub Макрос()
   
    Dim find_rng As Range, find As find
    Dim rng As Range, counter As Long
   
   
    '1. Отключение монитора (может это ускорит макрос и не будет мерцать).
    Application.ScreenUpdating = False
   
    '2. Создание объектов для поиска.
    Set find_rng = ActiveDocument.Range(0, 0)
    Set find = find_rng.find
   
    '3. Настройка поиска.
    find.text = "Библиографический список" & Chr(13) & "*" & Chr(12)
    find.Wrap = wdFindStop
    find.MatchWildcards = True
   
    '4. Поиск заголовка и разрыва. Ищутся все виды разрывов: страниц, разделов, у них у всех Chr12.
    Do While find.Execute = True
        counter = counter + 1
        Set rng = find_rng.Duplicate
        rng.MoveStart Unit:=wdParagraph, Count:=1
        rng.MoveEndWhile Cset:=Chr(12), Count:=wdBackward
        ChangeBibliolist rng
        find_rng.Collapse Direction:=wdCollapseEnd
    Loop
   
    '5. Поиск заголовка. На случай, если библиосписок в конце файла.
    find.text = "Библиографический список" & Chr(13)
    find.MatchWildcards = False
    If find.Execute = True Then
        counter = counter + 1
        Set rng = find_rng.Duplicate
        rng.SetRange rng.Start, ActiveDocument.Range.End
        rng.Select
        rng.MoveStart Unit:=wdParagraph, Count:=1
        ChangeBibliolist rng
    End If
   
    '6. Включение монитора.
    Application.ScreenUpdating = True
   
    '7. Сообщение.
    MsgBox "Найдено библиосписков: " & counter, vbInformation

End Sub

Private Sub ChangeBibliolist(rng As Range)
    ' Работа с библиосписком.
    rng.Font.Size = 11
    rng.Shading.BackgroundPatternColor = -687800474
End Sub

[свернуть]

[Anton]

Класс! Работает! Большое спасибо!