Sub RedBold(rng, start As Long, length As Long)
With rng.Characters(start:=start, length:=length).Font
.FontStyle = "Bold"
.Color = -16776961
End With
End Sub
Sub HighlightKeyWords()
'set Const CaseSensitive to true for case sensitive highlighting
Const CaseSensitive = False
'dimension variables
Dim WordList, c, w, Punctuation, p, cc As String, ww As String
Dim i As Long, start As Long, length As Long, ctr As Long, cols As Long
'intitialize punctuation symbols to ignore in an array
'if any other special symbols cause problems then add them to this array
Punctuation = Array(".", ",", "-", ";", ":", "?", "!")
'Check that named Range WordList exists and is a single column
On Error Resume Next
cols = Range("WordList").Columns.Count
If Err = 1004 Then
MsgBox "Establish a single column named range WordList before running this Sub"
Exit Sub
Else
If cols <> 1 Then
MsgBox "named range WordList must be a single column"
Exit Sub
End If
End If
Err.Clear
On Error GoTo 0
'initialize search word list, based on named range WordList
'consisting of a single column of words or phrases
WordList = Range("WordList").Value2
For Each w In WordList
i = i + 1
For Each p In Punctuation
w = Replace(w, p, " ")
Next p
WordList(i, 1) = " " & w & " "
If Not CaseSensitive Then WordList(i, 1) = LCase(WordList(i, 1))
Next w
'go through each cell in the selected range and highlight in red/bold the key words/phrases
For Each c In Selection
cc = c.Value2
For Each p In Punctuation
cc = Replace(cc, p, " ")
Next p
cc = " " & cc & " "
If Not CaseSensitive Then cc = LCase(cc)
For Each w In WordList
start = 1
length = 0
Do While start <> 0
start = InStr(start + length, cc, w)
length = Len(w) - 1
If start > 0 Then RedBold c, start - 1, length
Loop
Next w
Next c
End Sub
