Find and replace formatting of a single word in a cell

[kidwispa]

Hi all,

I have a sheet with over 40,000 rows of data and I'm looking to change the formatting to red bold every time a particular word appears in a cell (where there may be more than one word). I have looked online and found the following code that works really well to format the word to bold but I was just wondering at what point do I add in that I also want the font colour to be changed to red?

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("cosine")
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.Bold = True
End If
Next cCtr
Next myCell
End If
Next iCtr
Application.ScreenUpdating = True
End Sub

Thanks

 

[Richard Schollar]

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("cosine")
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
[COLOR="Red"]With [/COLOR]myCell.Characters(Start:=cCtr, _
Length:=Len(myWords(iCtr)))

   .Font.Bold = True
[COLOR="Red"]   .Font.Color = vbRed
End With[/COLOR]
End If
Next cCtr
Next myCell
End If
Next iCtr
Application.ScreenUpdating = True
End Sub

 

[kidwispa]

Thats great thanks