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?
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?