Word VBA Макросы: Выделить слова и абзац с наибольшим количеством найденных слов

[dancher]

Макрос позволяет по нажатию на CommandButton1 найти в документе Word заданное слово и выделить его (поменять его цвет на красный).
Но как сделать так чтоб слов можно было вводить несколько (через пробел или запятую)? Чтоб они записывались в массив получается.
И определить абзац с наибольшим количеством таких слов (тоже поменять цвет)?

Спойлер

Private Sub CommandButton1_Click()
    Dim word As String
    word = InputBox("ENTER A WORD")
    If word = Empty Then Exit Sub
    For Each i In ActiveDocument.words()
    With Selection.Find
      .Text = word
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindContinue
      .Format = True
      .MatchWholeWord = True
    End With
    Selection.Find.Execute
    If Not Selection.Font.ColorIndex = wdRed Then
      Selection.Font.ColorIndex = wdRed
      Selection.MoveRight Unit:=wdWord, count:=1
    Else
    Exit Sub
    End If
    Next i
End Sub

[свернуть]

Во вложении документ Word с текстом и макросом.
Помогите пожалуйста кто как может, буду очень благодарен.

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

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

Цитата:
И определить абзац с наибольшим количеством таких слов (тоже поменять цвет)?

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

[dancher]

Второй вариант.

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

Макрос

Sub макрос()

    ' Макрос ищет в основном тексте (в колонтитулах и другом не ищет).

    Dim phrases, sbornik()
    Dim pars As Collection, ub2 As Long
    Dim counter As Long, max As Long
    Dim i As Long, j As Long
   
   
    '1. Юзер указывает, какие фразы надо искать.
    phrases = InputBox("Введите искомые фразы через запятую:")
    ' Если юзер щёлкнул "Cancel".
    If phrases = "" Then
        Exit Sub
    End If
   
    '2. Откл. монитора (может это ускорит макрос и чтобы не мерцало).
    Application.ScreenUpdating = False
   
    '3. Разбивка введённого текста на части по запятой.
    phrases = Split(phrases, ",")
   
    '4. Создание ячеек в массиве "sbornik". В нём создаётся столько строк,
        ' сколько абзацев. И столько столбцов, сколько искомых фраз.
        ' То есть в массиве для каждого абзаца будет своя строка.
    ReDim sbornik(1 To ActiveDocument.Paragraphs.Count, 1 To UBound(phrases) + 1)
   
    '5. Поиск.
    For i = 0 To UBound(phrases)
        find phrases(i), sbornik(), i + 1
    Next i
   
    '6. Определение, в каком абзаце находится больше всего разных искомых слов.
    '1) Определение, сколько максимально было найдено в одном любом абзаце.
    ub2 = UBound(sbornik, 2)
    For i = 1 To UBound(sbornik, 1)
        counter = 0
        For j = 1 To ub2
            If sbornik(i, j) = True Then
                counter = counter + 1
            End If
        Next j
        sbornik(i, 1) = counter
        If counter > max Then
            max = counter
        End If
    Next i
   
    '2) Если вообще не было найдено искомых фраз.
    If max = 0 Then
        Application.ScreenUpdating = True
        MsgBox "Искомые фразы не найдены.", vbExclamation
        Exit Sub
    End If
   
    '3) Определение, в каком абзаце находится больше всего разных искомых слов.
    Set pars = New Collection
    For i = 1 To UBound(sbornik, 1)
        If sbornik(i, 1) = max Then
            pars.Add Item:=i
        End If
    Next i
   
    '4) Закраска абзацев с максимальным кол-вом.
    For i = 1 To pars.Count
        ActiveDocument.Paragraphs(pars(i)).Shading.BackgroundPatternColor = -654246042
    Next i
   
    '7. Вкл. монитора.
    Application.ScreenUpdating = True
   
    '8. Сообщение.
    MsgBox "Готово.", vbInformation

End Sub

Private Sub find(phrase, sbornik(), PhraseIndex As Long)

    Dim find_rng As Range, find As find
    Dim index As Long
   
   
    '1. Создание объектов, которые будут искать.
    Set find_rng = ActiveDocument.Range(0, 0)
    Set find = find_rng.find
   
    '2. Настройка поиска.
    find.Text = phrase
    find.Wrap = wdFindStop
   
    '3. Поиск.
    Do While find.Execute = True
   
        '1) Закраска найденной фразы.
        find_rng.Font.ColorIndex = wdRed
       
        '2) Запись порядкового номера абзаца в переменную "index".
            ' В ворде нет готового инструмента для определения порядкового номера абзаца,
            ' поэтому используется обходной способ - подсчёт кол-ва абзацев от
            ' начала файла до заданного фрагмента. В нашем случае до найденного фрагмента,
            ' включая сам найденный фрагмент.
        index = ActiveDocument.Range(0, find_rng.End).Paragraphs.Count
       
        '3) Запись в массив "sbornik" в соответствующую строку и столбец слова "True".
        sbornik(index, PhraseIndex) = True
       
    Loop
   
End Sub

[свернуть]

[dancher]

Спасибо за помощь.