Форум по VBA и MS Office

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

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