Макрос позволяет по нажатию на 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 с текстом и макросом.
Помогите пожалуйста кто как может, буду очень благодарен.
[вложение удалено администратором]
Макрос
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