Word VBA Макросы: Найти и выделить ФОНОМ искомый текст

[Dron_Spb]

Добрый день!

Пытаюсь написать макрос чтобы в тексте документа определенный набор символов, где бы он не встретился, выделялся ФОНОВЫМ цветом (желтым).
Причем текст с набором цифр в дате: две цифры в дне и одна цифра в годе 201?
.Text = "до ^#^# сентября 201^# г"

Т.е. такие сочетания чтобы были с фоном определенного цвета - не прозрачного:
до 12 сентября 2017 г 
до 30 сентября 2018 г   
и т.д.

Записал макрос по ручным действиям - он не работает:

Спойлер

Sub Макрос1()

    Selection.Range.HighlightColorIndex = wdYellow
    Options.DefaultHighlightColorIndex = wdYellow
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "до ^#^# сентября 201^# г"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
End Sub

[свернуть]

Помогите!

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

Выделения цветом у вас не происходит, т.к. в коде макроса нет выделения цветом. Для выделения цветом используйте параметр "Find.Replacement.Highlight".

Макрос

Sub Макрос1()

    Options.DefaultHighlightColorIndex = wdYellow
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "до ^#^# сентября 201^# г"
        .Replacement.Highlight = True
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
    End With
   
End Sub

[свернуть]

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

Если вы делаете замену во всём файле (сейчас ваш код так работает), то удобнее использовать такой код.
При использовании "ActiveDocument.Range" не нужно очищать от форматирования объекты "Find" и "Replace", т.к. они и так будут чистыми.
Параметры "Match" также можно не указывать, т.к. по умолчанию они False.

Макрос

Sub Макрос1()

    Options.DefaultHighlightColorIndex = wdYellow
    With ActiveDocument.Range.Find
        .Text = "до ^#^# сентября 201^# г"
        .Replacement.Highlight = True
        .Format = True
        .Execute Replace:=wdReplaceAll
    End With
   
End Sub

[свернуть]

[Dron_Spb]

Все заработало как часы!!!
Спасибище!

[Dron_Spb]

А еще можно вопрос?
А в принципе можно как-то посчитать кол-во включений данного текста, которые были обнаружены в документе?

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

В самом vba-ворде нет такой возможности, нужно самому писать код.

Макрос

Sub Макрос()

    Dim find_rng As Range, find As find
    Dim counter As Long
   
   
    '1. Откл. монитора.
    Application.ScreenUpdating = False
   
    '2. Создание объектов, которые будут искать.
    Set find_rng = ActiveDocument.Range(0, 0)
    Set find = find_rng.find
   
    '3. Настройка поиска.
    find.Text = "до ^#^# сентября 201^# г"
    find.Wrap = wdFindStop
   
    '4. Поиск.
    Do While find.Execute = True
        '1) Закраска.
        find_rng.HighlightColorIndex = wdYellow
        '2) Подсчёт, сколько найдено.
        counter = counter + 1
        '3) Превращение рейнджа в точку вставки и установка точки вставки после найденного фрагмента.
        find_rng.Collapse Direction:=wdCollapseEnd
    Loop
   
    '5. Вкл. монитора.
    Application.ScreenUpdating = True
   
    '6. Сообщение.
    MsgBox "Найдено и закрашено: " & counter, vbInformation
   
End Sub

[свернуть]

[Dron_Spb]

Супер!