Change font color in cells - Excell 2003

J

jfcby

Hello,

I have a calendar with January - December. In each cell (Range A3:G8)
there are 1-5 words, a number, and some are blank. I would like to be
able to change the font color on certain words in each cell.

I found a code but it gives me a error message
Run-time error '13'
Type Mismatch

Then it highlights this part of the code:

Set foundCell = .Find(what:=myWords(iCtr), _
LookIn:=xlValues, lookat:=xlPart, _
after:=.Cells(.Cells.Count))

This is the full code:

Sub ColorFontNORTH()
'Color font in cell multiple words

Application.ScreenUpdating = False

Dim myWords As Variant
Dim myRng As Range
Dim foundCell As Range
Dim iCtr As Long
Dim FirstAddress As String
Dim AllFoundCells As Range
Dim myCell As Range
Dim myStartPos As Long
Dim myWordLen As Long

myWords = Array("BOLTON - BW", "BOLTON - M", "BOLTON - Q", _
"BRUMBY - BW", "BRUMBY - M", "BRUMBY - Q", "HILL - Q", _
"MARY LYNDON - Q", "MORRIS - Q", "OGLETH DINING - BW", "OGLETH
DINING - M", _
"OGLETH DINING - Q", "OGLE-DIN - BW", "OGLE-DIN - M", "OGLE-DIN -
Q", _
"OGLETH HOUSE - BW", "OGLETH HOUSE - M", "OGLETH HOUSE - Q", _
"OGLE-HSE - BW", "OGLE-HSE - M", "OGLE-HSE - Q", "REED - BW", "REED
- M", _
"REED - Q", "REED HALL - BW", "REED HALL - M", "REED HALL - Q",
"RUSSELL - BW", _
"RUSSELL - M", "RUSSELL - Q", "BOOKSTORE - BW", "BOOKSTORE - M",
"BOOKSTORE - Q")

Set myRng = Range("A3:G8") '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
myStartPos = 1
Do While myStartPos > 0
myWordLen = Len(myWords(iCtr))
myStartPos = InStr(myStartPos, myCell.Value, _
myWords(iCtr), vbTextCompare)
If myStartPos > 0 Then
With myCell.Characters(Start:=myStartPos, _
Length:=myWordLen).Font
'.Name = "Arial"
'.FontStyle = "Bold"
'.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
'.Underline = xlUnderlineStyleNone
.ColorIndex = 7
End With
myStartPos = myStartPos + myWordLen
End If
Loop
Next myCell
End If
Next iCtr

Application.ScreenUpdating = True
End Sub

How can this code be changed so that I do not get a error message?
 
G

Guest

I'm guessing that since you are looking for an array item that you should be
looking in xlFormulas instead of xlValues.
 
G

Guest

With myRng
Dim afterRng as Range
set afterRn = .Areas(.Areas.count)
set afterRng = afterRng(afterRng.count)
Set foundCell = .Find(what:=myWords(iCtr), _
LookIn:=xlValues, lookat:=xlPart, _
after:=afterRng)


would be my guess.
 
J

jfcby

Hello Tom,

Your code gave this error message:

Run-time error '91':
object varible or With block variable not set

this is the part of the code that was highlighted:

Set afterRng = afterRng(afterRng.Count)

This is the full code to make sure I put your code in the correct
place:

Sub ColorFontNORTH()
'Color font in cell multiple words

Application.ScreenUpdating = False

Dim myWords As Variant
Dim myRng As Range
Dim afterRng As Range
Dim foundCell As Range
Dim iCtr As Long
Dim FirstAddress As String
Dim AllFoundCells As Range
Dim myCell As Range
Dim myStartPos As Long
Dim myWordLen As Long

myWords = Array("BOLTON - BW", "BOLTON - M", "BOLTON - Q", _
"BRUMBY - BW", "BRUMBY - M", "BRUMBY - Q", "HILL - Q", _
"MARY LYNDON - Q", "MORRIS - Q", "OGLETH DINING - BW", "OGLETH
DINING - M", _
"OGLETH DINING - Q", "OGLE-DIN - BW", "OGLE-DIN - M", "OGLE-DIN -
Q", _
"OGLETH HOUSE - BW", "OGLETH HOUSE - M", "OGLETH HOUSE - Q", _
"OGLE-HSE - BW", "OGLE-HSE - M", "OGLE-HSE - Q", "REED - BW", "REED
- M", _
"REED - Q", "REED HALL - BW", "REED HALL - M", "REED HALL - Q",
"RUSSELL - BW", _
"RUSSELL - M", "RUSSELL - Q", "BOOKSTORE - BW", "BOOKSTORE - M",
"BOOKSTORE - Q")

Set myRng = ActiveSheet.Range("A3:G8") '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:=xlFormulas, lookat:=xlPart, _
after:=.Cells(.Cells.Count))

With myRng
Set afterRn = .Areas(.Areas.Count)
Set afterRng = afterRng(afterRng.Count)
Set foundCell = .Find(what:=myWords(iCtr), _
LookIn:=xlValues, lookat:=xlPart, _
after:=afterRng)


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
myStartPos = 1
Do While myStartPos > 0
myWordLen = Len(myWords(iCtr))
myStartPos = InStr(myStartPos, myCell.Value, _
myWords(iCtr), vbTextCompare)
If myStartPos > 0 Then
With myCell.Characters(Start:=myStartPos, _
Length:=myWordLen).Font
'.Name = "Arial"
'.FontStyle = "Bold"
'.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
'.Underline = xlUnderlineStyleNone
.ColorIndex = 7
End With
myStartPos = myStartPos + myWordLen
End If
Loop
Next myCell
End If
Next iCtr

Application.ScreenUpdating = True
End Sub

Thanks for your help,
Frankie
 
G

Guest

I suspect you didn't correct the typo in my code:

With myRng
Dim afterRng as Range
set afterRng = .Areas(.Areas.count) '<== corrected typo
set afterRng = afterRng(afterRng.count)
Set foundCell = .Find(what:=myWords(iCtr), _
LookIn:=xlValues, lookat:=xlPart, _
after:=afterRng)
 
J

jfcby

Hey Tom,

I missed the typo. The code works great after the correction was made.
Thank you for your help!

Frankie
 
P

Peter T

First of all don't need the intersect, simply

Set myRng = myRng.Cells.SpecialCells(xlCellTypeConstants, xlTextValues)

Although use the above to early abort if no text cells, the Find function is
so fast relative to individually formating characters I'd work with the
orginal range and avoid complicating matters.

Have a go with this -

Option Explicit
Sub FindAndFormatCharacters()
Dim myRng As Range
Dim foundCell As Range
Dim sFirstAddress As String
Dim vMyWords, vWord

vWord = "more APPLES and Oranges and "
vWord = vWord & vWord & "also 123 pears "
Range("A1,A3,A5,c7,c9") = vWord ' for testing

Set myRng = Range("A1:c10")

With myRng.Font ' reset for testing
.Bold = False
.ColorIndex = xlAutomatic
End With

vMyWords = Array("APPLES", "PEARS", "ORANGES", 123)
For Each vWord In vMyWords
'On Error Resume Next
Set foundCell = Nothing

Set foundCell = myRng.Find(What:=vWord, LookIn:=xlValues, _
LookAt:=xlPart, MatchCase:=False)
On Error GoTo 0
If Not foundCell Is Nothing Then
sFirstAddress = foundCell.Address
FmtChars foundCell, vWord
Do
Set foundCell = myRng.FindNext(foundCell)
If sFirstAddress <> foundCell.Address Then

FmtChars foundCell, vWord
End If
Loop Until sFirstAddress = foundCell.Address
End If
Next
End Sub

Sub FmtChars(cel As Range, v)
Dim pos As Long, nLen As Long

nLen = Len(v)
pos = 1
Do
pos = InStr(pos, cel.Value, v, vbTextCompare)
If pos Then
With cel.Characters(pos, nLen).Font
.Bold = True
.ColorIndex = 3
End With
pos = pos + 1
End If
Loop Until pos = 0
Exit Sub

End Sub

Regards,
Peter T

PS, was about to post and see with Tom's help you've solved your problem, so
the above FWIW
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Search and Replace a Spacific Character with Conditional Formating 17
Locate and Move Specific Cells 2
Deleting rows 3
deleting rows based on criteria 7
type mismatch here! 2
searching for words 2
how to fill an array with the nth number in a list 4
delete code keeps going and coing 5

Top