Sure to be a hit. Code will highlight and bold user defined text strings within cell text strings. Very nice code which can be implemented into text type macros and tools. Macro can easily be modified to perform as a function subroutine. To use it, simply set up values for range to search in (Yes, it can be a 3d range spanning multiple columns and rows). Set up your array of words to search for. I have attached a simple workbook with working example as well as included code posting. Enjoy.
Code
Sub ColorandBold()
'USE-COLOR AND BOLD TEXT STRINGS WITHIN TEXT EXCEL VBA
'BROUGHT TO YOU BY WWW.PROGRAMMINGLIBRARY.COM
'CREATED BY MARK SLOBODA
'************************* DEC VARS *******************************
Dim myCell As Range
Dim myRng As Range
Dim FirstAddress As String
Dim iCtr As Long
Dim letCtr As Long
Dim startrow As Long 'BEGINNING OF RANGE
Dim endrow As Long ' END OF RANGE
Dim startcolumn As Integer 'BEGINNING COLUMN
Dim endcolumn As Integer 'END COLUMN
'************************* SET VALUES*****************************
'DUMMY VALUES - COULD BE PASSED
startrow = 2
endrow = 5
startcolumn = 1
endcolumn = 2
'SET UP RANGE YOU ARE COLORING AND BOLDING -YOU COULD MODIFY TO PASS VALUE TO
Set myRng = Range(Cells(startrow, startcolumn), Cells(endrow, endcolumn))
'SET UP ARRAY WITH WORDS YOU WANT TO COLOR AND BOLD - YOU COULD PUSH VALUES FROM A LISTBOX TO THIS ARRAY
myWords = Array("dog", "cat", "hamster")
'BEGIN MASTER LOOP---------------------------------------
For iCtr = LBound(myWords) To UBound(myWords)
'ERROR FOUND-BYPASS
On Error Resume Next
With myRng
Set myCell = .Find(What:=myWords(iCtr), After:=.Cells(1), _
LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
'LOGIC CHECK
If Not myCell Is Nothing Then
FirstAddress = myCell.Address
Do
For letCtr = 1 To Len(myCell.Value)
If StrComp(Mid(myCell.Value, letCtr, _
Len(myWords(iCtr))), _
myWords(iCtr), vbTextCompare) = 0 Then
myCell.Characters(Start:=letCtr, _
Length:=Len(myWords(iCtr))) _
.Font.ColorIndex = 5
End If
Next letCtr
For letCtr = 1 To Len(myCell.Value)
If StrComp(Mid(myCell.Value, letCtr, _
Len(myWords(iCtr))), _
myWords(iCtr), vbTextCompare) = 0 Then
myCell.Characters(Start:=letCtr, _
Length:=Len(myWords(iCtr))) _
.Font.FontStyle = "Bold"
End If
Next letCtr
'GET NEXT ADDRESS
Set myCell = .FindNext(myCell)
Loop While Not myCell Is Nothing _
And myCell.Address <> FirstAddress
End If
End With
Next iCtr
End Sub