Highlight Whole Paragraph Containing Specific Text

[VB-AN-IZ]

So, I've plagiarized this code:
http://www.msofficeforums.com/word-vba/16893-macro-highlight-list-words.html#post48397

It highlights any text between:

Split("

", ",")

...as long as there are no spaces between each comma.


Sub ListChange()
Dim r As Range
Dim MyList() As String
Dim i As Long
MyList = Split("dot,com,like", ",")
For i = 0 To UBound(MyList())
Set r = ActiveDocument.Range
With r.Find
.Text = MyList(i)
.Replacement.Highlight = wdYellow
.Execute Replace:=wdReplaceAll
End With
Next
End Sub

Is there a way to modify this code – or, I guess, create an entirely new one – which highlights the entire paragraph containing specific text?

For example, in this text:

You can do anything, but not everything.
Perfection is achieved, not when there is nothing more to add, but when there is nothing left to take away.
The richest man is not he who has the most, but he who needs the least.
You miss 100% of the shots you never take.


...could I search for the text "richest" and highlight the entire third paragraph?

I really have no idea how to specify "up to last and next paragraph" without getting into trouble...

Thanks for any help!

[macropod]

Try something along the lines of:

Sub ListChange()
Dim r As Range
Dim MyList() As String
Dim i As Long
MyList = Split("dot,com,like", ",")
For i = 0 To UBound(MyList())
Set r = ActiveDocument.Range
With r.Find
.Text = "[!^13]@" & MyList(i) & "*^13"
.Replacement.Highlight = wdYellow
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
Next
End Sub
This should work for any paragraph where the find expression is not the first word in the paragraph. Note that the code is also now case-sensitive. More complicated code would be required to remove case-sensitivity and to handle first-words.

[mana]

Option Explicit


Sub test()
Dim r As Range
Dim s As String

s = "richest"


Set r = ActiveDocument.Range

With r.Find
.Text = s
Do While .Execute
r.Paragraphs(1).Range.HighlightColorIndex = wdYellow
Loop
End With


End Sub

[VB-AN-IZ]

Excellent. Thank you.

Is there a more efficient way to highlight several at once ("richest" and "perfection") than this?


Sub test()

Dim r As Range
Dim s As String

s = "richest"

Set r = ActiveDocument.Range

With r.Find
.Text = s
Do While .Execute
r.Paragraphs(1).Range.HighlightColorIndex = wdYellow
Loop
End With

s = "perfection"

Set r = ActiveDocument.Range

With r.Find
.Text = s
Do While .Execute
r.Paragraphs(1).Range.HighlightColorIndex = wdYellow
Loop
End With

End Sub

[mana]

Option Explicit


Sub test2()
Dim r As Range
Dim s

For Each s In Array("richest", "perfection")
Set r = ActiveDocument.Range
With r.Find
.Text = s
.Highlight = False
Do While .Execute
r.Paragraphs(1).Range.HighlightColorIndex = wdYellow
Loop
End With
Next


End Sub

[VB-AN-IZ]

Ahhhh. That answers my next follow-up question as well. Excellent.

Works brilliantly. Thanks very much!

[mana]

Is there a more efficient way to highlight several at once ("richest" and "perfection") than this?


Did you try macropod's #2 ?

[macropod]

You could try:

Sub ListChange()
Application.ScreenUpdating = False
Dim MyList() As String, i As Long
MyList = Split("dot,com,like", ",")
With ActiveDocument.Range.Find
.Replacement.Highlight = wdYellow
.MatchWildcards = True
For i = 0 To UBound(MyList())
.Text = "[!^13]@" & MyList(i) & "*^13"
.Execute Replace:=wdReplaceAll
.Text = "[!^13]" & MyList(i) & "*^13"
.Execute Replace:=wdReplaceAll
Next
End With
Application.ScreenUpdating = True
End Sub
With many instances to process this would be far faster than the code in post #5, for example.