excel format string based on range

Question

So I have column A of long text, in which several names are mentioned. Each cell in the column is a mini-essay of sorts. Some important names are repeated throughout every cell and I need to highlight these names in a different colour. So, a macro that conditionally formats when it finds these names.

I'm able to do that when the names I'm looking for are fixed, but I've been trying to find a way to search a list of names (in Sheet B) so that I can add to this list of names as and when necessary. I've been looking around google and here but I've only found ways to find based on either 1) a specific string of text, or 2) a single cell. I can't figure out how to map the finding to a variable range of cells.

Using Excel 2003.

By name:

Sub FormatTest()
Dim g As Range
For Each g In Selection.Cells
    FormatCell g
Next
End Sub


Sub FormatCell(g As Range)
Dim pos1 As Integer, pos2 As Integer
pos1 = 1
pos2 = InStr(pos1, g.Text, "Alicia")
v = Len("Alicia")
pos3 = pos2 + v
g.Characters(Start:=pos2, Length:=pos3 - pos2).Font.Color = RGB(0, 0, 255)    
End Sub

By cell:

Sub FormatTest()
Dim e As Range
For Each e In Selection.Cells
    FormatCell e
Next
End Sub
Sub FormatCell(e As Range)
Dim pos1 As Integer, pos2 As Integer
pos1 = 1
pos2 = InStr(pos1, e.Text, Range("B20"))
v = len(Range("B20"))
pos3 = pos2 + v
e.Characters(Start:=pos2, Length:=pos3 - pos2).Font.Color = RGB(0, 0, 255)

Answer 1

This update to your code will do it, but will not work (just like your initial code) if you have multiple instances of the name in one cell. Will that happen?

Sub FormatTest()
Dim g As Range, rgWords As Range, rgWord As Range

'turn off updates to speed up code execution
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With

'set the range where you keep the list of words you're searching for here:
Set rgWords = Sheets("Sheet2").Range("A1:A3")

For Each g In Selection.Cells
    For Each rgWord In rgWords.Cells
        if len(rgWord)>0 then FormatCell g, rgWord.Text
    Next rgWord
Next

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With

End Sub


Sub FormatCell(g As Range, sWord As String)
Dim pos1 As Integer, pos2 As Integer
pos1 = 1
pos2 = InStr(pos1, g.Text, sWord)
If pos2 = 0 Then Exit Sub
v = Len(sWord)
pos3 = pos2 + v
g.Characters(Start:=pos2, Length:=pos3 - pos2).Font.Color = RGB(0, 0, 255)
End Sub

If you can have multiple instances, update the FormatCell sub to the following:

Sub FormatCell(g As Range, sWord As String)
Dim pos1 As Integer, pos2 As Integer
pos1 = 1
pos2 = InStr(pos1, g.Text, sWord)
v = Len(sWord)

Do While pos2 > 0

    pos3 = pos2 + v
    g.Characters(Start:=pos2, Length:=pos3 - pos2).Font.Color = RGB(0, 0, 255)

    pos2 = InStr(pos2 + v, g.Text, sWord)

Loop
End Sub