Search for text, change font color

[John]

I would like to have Excel search through a workbook, and change the font
color of a string of text wherever it occurs in the workbook. For example if
I'm searching for "widgets", if cell A14 contains " no widgets were sold
this week", I would like the font color of "widgets" to be red. If that
can't be done, I'll settle for the font color of all of cell A14 to be red.
Can it be done without VBA?

 

[Norman Jones]

Hi John,

See the VBA help example for the FindNext method.

Here is a minor adaptation:

Sub Tester03()
Dim sStr As String
Dim sh As Worksheet

Set sh = ActiveSheet

sStr = "widget"

With sh.Cells
Set c = .Find(sStr, _
After:=Range("A1"), _
LookIn:=xlValues, _
LookAt:=xlPart, _
MatchCase:=False)

If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Interior.ColorIndex = 3
Set c = .FindNext(c)
Loop While Not c Is Nothing And _
c.Address <> firstAddress
End If
End With

End Sub

 

[Dave Peterson]

If you use xl2002, you can change the whole cell's color via
Edit|Replace (click on Options to see the formatting choices)

If you want to change the color of just the characters, you need VBA in all
versions.

You want a macro????

Option Explicit
Option Compare Text
Sub testme()

Application.ScreenUpdating = False

Dim myWords As Variant
Dim myRng As Range
Dim foundCell As Range
Dim iCtr As Long 'word counter
Dim cCtr As Long 'character counter
Dim FirstAddress As String
Dim AllFoundCells As Range
Dim myCell As Range

'add other words here
myWords = Array("widgets")

Set myRng = Selection

On Error Resume Next
Set myRng = Intersect(myRng, _
myRng.Cells.SpecialCells(xlCellTypeConstants, xlTextValues))
On Error GoTo 0

If myRng Is Nothing Then
MsgBox "Please choose a range that contains text constants!"
Exit Sub
End If

For iCtr = LBound(myWords) To UBound(myWords)
FirstAddress = ""
Set foundCell = Nothing
With myRng
Set foundCell = .Find(what:=myWords(iCtr), _
LookIn:=xlValues, lookat:=xlPart, _
after:=.Cells(.Cells.Count))

If foundCell Is Nothing Then
MsgBox myWords(iCtr) & " wasn't found!"
Else
Set AllFoundCells = foundCell
FirstAddress = foundCell.Address
Do
If AllFoundCells Is Nothing Then
Set AllFoundCells = foundCell
Else
Set AllFoundCells = Union(foundCell, AllFoundCells)
End If
Set foundCell = .FindNext(foundCell)

Loop While Not foundCell Is Nothing _
And foundCell.Address <> FirstAddress
End If

End With

If AllFoundCells Is Nothing Then
'do nothing
Else
For Each myCell In AllFoundCells.Cells
For cCtr = 1 To Len(myCell.Value)
If Mid(myCell.Value, cCtr, Len(myWords(iCtr))) _
= myWords(iCtr) Then
myCell.Characters(Start:=cCtr, _
Length:=Len(myWords(iCtr))) _
.Font.colorindex = 3
End If
Next cCtr
Next myCell
End If
Next iCtr
Application.ScreenUpdating = True

End Sub

This line:
myCell.Characters(Start:=cCtr, _
Length:=Len(myWords(iCtr))) _
.Font.colorindex = 3
changes the color.