Determine the colour of text in each cell in a range of cells

  • Thread starter Thread starter Khurram
  • Start date Start date
K

Khurram

Hi all,
I'm given a single column of data that covers a variable number of
rows. I need to count the number of rows that contain text that is
coloured red. It sounds simple and I've been trying to use the
Format.Find function but that never comes to an end. Is there a way
for me to go through the range of cells and and count how many are
coloured red? There no other colours except black and red. Below is
my attempt at this but does not work.

Sub Macro4()
Dim myRange As Range
Dim cellValue As String
Dim redCounter As Long

redCounter = 0:

Set myRange = Range("A1:A7")
myRange.Select

Do Until (myRange.End(xlDown) = True)

With Application.FindFormat.Font
.Subscript = False
.ColorIndex = 3
End With
Selection.Find(What:="", After:=ActiveCell,
LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows,
SearchDirection:=xlNext, MatchCase:=False,
SearchFormat:=True).Cells.Select
redCounter = redCounter + 1:
Selection.FindNext(After:=ActiveCell).Activate
Loop

End Sub

Thank you kindly
Khurram
 
Assuming the initial FIND works, then the structure would be like this.

Sub Macro4()
Dim myRange As Range
Dim redCounter As Long
Dim sAddr as String
Dim rng as Range

redCounter = 0:

Set myRange = Range("A1:A7")

With Application.FindFormat.Font
.Subscript = False
.ColorIndex = 3
End With

set rng = myRange.Find(What:="", _
After:=myrange(myrange.count),
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=True)

if not rng is nothing then
sAddr = rng.Address
do
redCounter = redCounter + 1
set rng = myrange.FindNext(After:=rng)
Loop while rng.address <> sAddr
end if
msgbox redCounter
End Sub
 
Sub Macro4()
Dim myRange As Range
Dim cell As Range
Dim redCounter As Long

redCounter = 0:

Set myRange = Range("A1:A7")
For Each cell In myRange
If cell.Interior.ColorIndex = 3 Then
redCounter = redCounter + 1
End If
Next cell
End Sub

--
---
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)
 
Thank you Mike, Tom and Bob,
I shall be taking heed of each of your suggestions and will reply here
with details of which ones worked for me.

Cheers
Khurram
 
Hi all.
I've found that Bob's answer served my purposes the best however a
small substitution was required to use the Font attribute rather than
the ColorIndex attribute as the ColorIndex attribute refers to the
colour of the cell background and NOT the text it contains. Working
code below:

Sub Macro4()
Dim myRange As Range
Dim cell As Range
Dim redCounter As Long

redCounter = 0:


Set myRange = Range("A1:A7")
For Each cell In myRange
If cell.Interior.Font = 3 Then
redCounter = redCounter + 1
End If
Next cell
End Sub

Thank you all again for the help
Khurram
 
Working
code below:
Click to expand...

Code doesn't work!

If you want the Font color, the correct approach would be

Sub Macro4()
Dim myRange As Range
Dim cell As Range
Dim redCounter As Long

redCounter = 0:


Set myRange = Range("A1:A7")
For Each cell In myRange
If cell.Font.ColorIndex = 3 Then
redCounter = redCounter + 1
End If
Next cell
End Sub

the code you posted raises a huge error and it is unclear how you evaluated
anything. Also, interior refers to the cell background and Font refers to
the font characteristics/text of the cell. Both have a colorindex property.
This approach would be the slowest, but based on the tiny area you are
examining, that is a moot point. But if your happy, have a good day.
 
Hi Tom,
You are absolutely correct and the code you posted is the code I am
using in my macro. I have no idea how I've managed to mix that up but
its obvious that I'm incapable of copying and pasting :-)

However I will point out that I did try both yours and Bobs solutions
and followed the link provided by Mike and its the explanations
provided on that website that allowed me to amend Bob's code to suite
my purposes. Which is why I'm thankful for the trio for the help
provided.

Kind regards
Khurram
 
Back
Top