Coloring Specific Letters in a Spreadsheet


Posted by Glenn on July 12, 2001 3:58 PM

I have several spreadsheets that contain extensive text. I would like to color all W's, X's and Y's that appear in the spreadsheets.

Also I would like to bold all instances of specific phrases that appear in the spreadsheet.

Thank You
Glenn


Posted by luxio on July 12, 2001 11:40 PM


Check the help for "conditional formatting. You'll ge the answer there.
==================================




Posted by Ivan F Moala on July 13, 2001 6:22 AM

todo this you will have to use VBA
Try this routine;

Option Explicit
Option Compare Text
Option Base 1

Sub Colour_CertainText()
Dim AllTxt As Range
Dim TxtCell As Range
Dim sCell As Range
Dim Txt As String
Dim Pos As Double
Dim W As Double, X As Double, Y As Double
Dim Wc As Double, Xc As Double, Yc As Double
Dim Num As Double
Dim StArray
Dim PhrArray
Dim k As Double


Set AllTxt = Selection.SpecialCells(xlCellTypeConstants, 2)

PhrArray = Array("test", "one", "Two")
StArray = Array("w", "x", "y")

For Each TxtCell In AllTxt
'//////////////////////////
'/ 1st Change Colours /
'/////////////////////////

'Find last occurance of W
W = InStrR(TxtCell.Text, StArray(1), 1)
'if found then How many are there
If W > 0 Then
Wc = CountStr(TxtCell.Text, StArray(1), 1, False)
'Now change letter color
Pos = 1
For Num = 1 To Wc
Pos = InStr(Pos + 1, TxtCell, StArray(1))
ChangeCell_Text TxtCell, Pos, 1, 3
Next
End If
'--------------------------------------------
'Find last occurance of x
X = InStrR(TxtCell, StArray(2), 1)
'if found then How many are there
If X > 0 Then
Xc = CountStr(TxtCell.Text, StArray(2), 1, False)
'Now change letter color
Pos = 1
For Num = 1 To Xc
Pos = InStr(Pos + 1, TxtCell, StArray(2))
ChangeCell_Text TxtCell, Pos, 1, 3
Next
End If
'--------------------------------------------
'Find last occurance of x
Y = InStrR(TxtCell.Text, StArray(3), 1)
'if found then How many are there
If Y > 0 Then
Yc = CountStr(TxtCell.Text, StArray(3), 1, False)
'Now change letter color
Pos = 1
For Num = 1 To Yc
Pos = InStr(Pos + 1, TxtCell, StArray(3))
ChangeCell_Text TxtCell, Pos, 1, 3
Next
End If
'--------------------------------------------
'//////////////////////////////
'/ 2nd Change Font to BOLD /
'//////////////////////////////
Y = 1
For X = 1 To UBound(PhrArray)
If InStr(1, TxtCell, PhrArray(Y)) > 0 Then
k = CountStr(TxtCell.Text, PhrArray(Y), X, True)
For W = 1 To k
MakeBold TxtCell, InStr(W, TxtCell, PhrArray(Y)), Len(PhrArray(Y))
Next
End If
Y = Y + 1
Next
Next
MsgBox "Done"
End Sub

Function InStrR(ByVal sTarget As String, ByVal sFind As String, _
ByVal iCompare As Long) As Long
'/////////////////////////////////////
'/ Find last occurance of string Ms /
'/////////////////////////////////////
'0 Binary Comparison
'1 Text Comparison
'2 Database Comparison (Microsoft Access)
Dim P As Long, LastP As Long, Start As Long

P = InStr(1, sTarget, sFind, iCompare)

Do While P
LastP = P
P = InStr(LastP + 1, sTarget, sFind, iCompare)
Loop

InStrR = LastP

End Function

Function CountStr(Str As String, WStr, st, Bold As Boolean) As Double
Dim X As Double, Y As Double, temp As String
X = 1
If Not Bold Then
Do Until X > Len(Str)
temp = Mid(Str, X, st)
If temp = WStr Then Y = Y + 1
X = X + 1
Loop
Else
Do Until X > Len(Str)
temp = Mid(Str, st + X, Len(WStr))
If temp = WStr Then Y = Y + 1
X = X + 1
Loop
End If

CountStr = Y

End Function

Sub ChangeCell_Text(CellTxt As Range, st As Double, Ln As Double, Kolor As Double)
CellTxt.Characters(Start:=st, Length:=Ln).Font.ColorIndex = Kolor
End Sub

Sub MakeBold(Rg As Range, st As Double, Ln As Double)
Rg.Characters(Start:=st, Length:=Ln).Font.FontStyle = "Bold"
End Sub

HTH

Ivan