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