Выделение цветом абзацов с одинаковыми числовыми значениями в тексте в Word'e

[viter.alex]

Тогда вот так, наверное

Sub HighlightPars()

  Dim iStart As Long 'Верхняя граница диапазона поиска
  Dim oParRng As Range 'Абзац, в котором найдено первое число
  Dim bNotShaded As Boolean: bNotShaded = True
  Dim oCurrDoc As Document 'Рабочий документ
  Dim nColor As Long 'Цвет выделения
  Dim sNumber As String 'Искомое число
  
  Set oCurrDoc = ActiveDocument
  With oCurrDoc.Range(iStart, oCurrDoc.Range.End).Find
    .Text = "[0-9]{8}" 'Ищем любое число из восьми цифр
    .MatchWildcards = True 'Подстановочные знаки
    .Font.Shading.BackgroundPatternColor = wdColorAutomatic 'Без заливки
    While .Execute
      .Parent.Select
      iStart = .Parent.End 'Конец найденного слова
      nColor = GetRandomColor 'Получаем случайный цвет
      sNumber = .Parent.Text 'Найденный текст
      'Запоминаем абзац, в котором нашли номер
      Set oParRng = .Parent.Paragraphs.First.Range
      'Запускаем еще один поиск, но уже с конкретным числом
      With oCurrDoc.Range(iStart, oCurrDoc.Range.End).Find
        .Text = sNumber
        While .Execute
          'Закрашиваем первый абзац, в котором нашли номер
          If bNotShaded Then oParRng.Font.Shading.BackgroundPatternColor = nColor: bNotShaded = False
          'Закрашиваем остальные абзацы
          .Parent.Paragraphs.First.Range.Font.Shading.BackgroundPatternColor = nColor
        Wend
      End With
    Wend
  End With
End Sub

Function GetRandomColor() As Long
  Randomize
  Dim R As Byte
  Dim G As Byte
  Dim B As Byte
  
  R = Int(255 * Rnd) + 1
  G = Int(255 * Rnd) + 1
  B = Int(255 * Rnd) + 1
  
  GetRandomColor = RGB(R, G, B)
End Function

[xamillion]

Сообщение от viter.alex

Тогда вот так, наверное

вот именно то - что доктор прописал... спасибо за неоценимую поддержку...

[viter.alex]

Строчку .Parent.Select можно убрать. Это отладочная

[xamillion]

Сообщение от viter.alex

Строчку .Parent.Select можно убрать. Это отладочная

понял... спасибо что уделяете на недоучек время... )))

[xamillion]

А как бы сделать "Выделение цветом", чтобы каждый раз не заходить в "Границы и заливку" для снятия цветовой закраски?

[Sasha_Smirnov]

Sub Макрос1()
Selection.Range.HighlightColorIndex = wdNoHighlight
End Sub

И назначить этому кнопку на панели либо клавишу (комбинацию клавиш).

[xamillion]

Неправильно выразился... ниже представленный код закрашивает через "Заливку и границы", а более удобно через "Выделение цветом"...

Sub HighlightPars()

  Dim iStart As Long 'Верхняя граница диапазона поиска
  Dim oParRng As Range 'Абзац, в котором найдено первое число
  Dim bNotShaded As Boolean: bNotShaded = True
  Dim oCurrDoc As Document 'Рабочий документ
  Dim nColor As Long 'Цвет выделения
  Dim sNumber As String 'Искомое число
  
  Set oCurrDoc = ActiveDocument
  With oCurrDoc.Range(iStart, oCurrDoc.Range.End).Find
    .Text = "[0-9]{8}" 'Ищем любое число из восьми цифр
    .MatchWildcards = True 'Подстановочные знаки
    .Font.Shading.BackgroundPatternColor = wdColorAutomatic 'Без заливки
    While .Execute
      .Parent.Select
      iStart = .Parent.End 'Конец найденного слова
      nColor = GetRandomColor 'Получаем случайный цвет
      sNumber = .Parent.Text 'Найденный текст
      'Запоминаем абзац, в котором нашли номер
      Set oParRng = .Parent.Paragraphs.First.Range
      'Запускаем еще один поиск, но уже с конкретным числом
      With oCurrDoc.Range(iStart, oCurrDoc.Range.End).Find
        .Text = sNumber
        While .Execute
          'Закрашиваем первый абзац, в котором нашли номер
          If bNotShaded Then oParRng.Font.Shading.BackgroundPatternColor = nColor: bNotShaded = False
          'Закрашиваем остальные абзацы
          .Parent.Paragraphs.First.Range.Font.Shading.BackgroundPatternColor = nColor
        Wend
      End With
    Wend
  End With
End Sub

Function GetRandomColor() As Long
  Randomize
  Dim R As Byte
  Dim G As Byte
  Dim B As Byte
  
  R = Int(255 * Rnd) + 1
  G = Int(255 * Rnd) + 1
  B = Int(255 * Rnd) + 1
  
  GetRandomColor = RGB(R, G, B)
End Function