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