Counting Color Cells

M

MC82

I am trying to practice writing macros by creating some of these from
scratch. I ran into a problem and I was hoping someone here could
help.

HERE IS HOW I CURRENTLY USE IT:
You select a region, then while holding down ctrl, click on the color
of the cell in the selection in which you would like to count. (if it
is the first cell you selected, you do not have to reselect the color)

The macro should come back with the color and the number of cells with
that color.

PROBLEM:
- This macro does not seem to display the correct count when I scroll
down the page a little and select the whole column (the colored cell i
want should be the first in the first visible row of the column)

- If I select the cells going from the bottom up, the count is
incorrect as well.


Code:
--------------------

Sub CountColors()
Dim rAllRange As Range
Dim aRange As Range
Dim strAdd As Range
Dim Cnt As Integer
Dim rCell As Range
Dim M1 As Boolean
Dim Clr As String
Dim bEntireColumn As Boolean
Dim bEntireRow As Boolean

With Selection
bEntireColumn = .Address = .EntireColumn.Address
bEntireRow = .Address = .EntireRow.Address
End With

On Error Resume Next
Set rAllRange = Selection

If rAllRange.Cells.Count < 2 Then
MsgBox "Your selection is not valid", vbInformation
On Error GoTo 0
Exit Sub
End If

Application.Calculation = xlCalculationManual

Cnt = 0
For Each rCell In rAllRange
If Cnt = 0 Then
If rCell.Address = ActiveCell.Address Then
M1 = True
Else
M1 = False
End If
End If

If rCell.Interior.ColorIndex = ActiveCell.Interior.ColorIndex Then
Cnt = Cnt + 1
End If
Next rCell

If ActiveCell.Interior.ColorIndex = 1 Then
Clr = "Black"
ElseIf ActiveCell.Interior.ColorIndex = 53 Then
Clr = "Brown"
ElseIf ActiveCell.Interior.ColorIndex = 52 Then
Clr = "Olive Green"
ElseIf ActiveCell.Interior.ColorIndex = 51 Then
Clr = "Dark Green"
ElseIf ActiveCell.Interior.ColorIndex = 49 Then
Clr = "Dark Teal"
ElseIf ActiveCell.Interior.ColorIndex = 11 Then
Clr = "Dark Blue"
ElseIf ActiveCell.Interior.ColorIndex = 55 Then
Clr = "Indigo"
ElseIf ActiveCell.Interior.ColorIndex = 56 Then
Clr = "Gray [80%]"
ElseIf ActiveCell.Interior.ColorIndex = 9 Then
Clr = "Dark Red"
ElseIf ActiveCell.Interior.ColorIndex = 46 Then
Clr = "Orange"
ElseIf ActiveCell.Interior.ColorIndex = 12 Then
Clr = "Dark yellow/Green"
ElseIf ActiveCell.Interior.ColorIndex = 10 Then
Clr = "Green"
ElseIf ActiveCell.Interior.ColorIndex = 14 Then
Clr = "Teal"
ElseIf ActiveCell.Interior.ColorIndex = 5 Then
Clr = "Blue"
ElseIf ActiveCell.Interior.ColorIndex = 47 Then
Clr = "Blue-Gray"
ElseIf ActiveCell.Interior.ColorIndex = 16 Then
Clr = "Gray [50%]"
ElseIf ActiveCell.Interior.ColorIndex = 3 Then
Clr = "Red"
ElseIf ActiveCell.Interior.ColorIndex = 45 Then
Clr = "Light Orange"
ElseIf ActiveCell.Interior.ColorIndex = 43 Then
Clr = "Lime Colored"
ElseIf ActiveCell.Interior.ColorIndex = 50 Then
Clr = "Sea Green Colored"
ElseIf ActiveCell.Interior.ColorIndex = 42 Then
Clr = "Aqua Colored"
ElseIf ActiveCell.Interior.ColorIndex = 41 Then
Clr = "Light Blue"
ElseIf ActiveCell.Interior.ColorIndex = 13 Then
Clr = "Violet"
ElseIf ActiveCell.Interior.ColorIndex = 48 Then
Clr = "Gray [40%]"
ElseIf ActiveCell.Interior.ColorIndex = 7 Then
Clr = "Pink"
ElseIf ActiveCell.Interior.ColorIndex = 44 Then
Clr = "Gold Colored"
ElseIf ActiveCell.Interior.ColorIndex = 6 Then
Clr = "Yellow"
ElseIf ActiveCell.Interior.ColorIndex = 4 Then
Clr = "Bright Green"
ElseIf ActiveCell.Interior.ColorIndex = 8 Then
Clr = "Turquoise"
ElseIf ActiveCell.Interior.ColorIndex = 33 Then
Clr = "Sky Blue"
ElseIf ActiveCell.Interior.ColorIndex = 54 Then
Clr = "Plum Colored"
ElseIf ActiveCell.Interior.ColorIndex = 15 Then
Clr = "Gray [25%]"
ElseIf ActiveCell.Interior.ColorIndex = 38 Then
Clr = "Rose Colored"
ElseIf ActiveCell.Interior.ColorIndex = 40 Then
Clr = "Tan Colored"
ElseIf ActiveCell.Interior.ColorIndex = 36 Then
Clr = "Light Yellow"
ElseIf ActiveCell.Interior.ColorIndex = 35 Then
Clr = "Light Green"
ElseIf ActiveCell.Interior.ColorIndex = 34 Then
Clr = "Light Turquoise"
ElseIf ActiveCell.Interior.ColorIndex = 37 Then
Clr = "Pale Blue"
ElseIf ActiveCell.Interior.ColorIndex = 39 Then
Clr = "Lavender Colored"
ElseIf ActiveCell.Interior.ColorIndex = 2 Then
Clr = "White"
ElseIf ActiveCell.Interior.ColorIndex = -4142 Then
Clr = "Uncolored"
Else
Clr = "Other Colored"
End If

If M1 = False Then
MsgBox "There Are " & Cnt - 1 & " " & Clr & " Cells In Your Selection"
Else
If bEntireColumn Then
MsgBox "There Are " & Cnt & " " & Clr & " Cells In Your Selection"
ElseIf bEntireRow Then
MsgBox "There Are " & Cnt - 1 & " " & Clr & " Cells In Your Selection"
Else
MsgBox "There Are " & Cnt & " " & Clr & " Cells In Your Selection"
End If

End If

Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
End Sub
 
T

Tom Ogilvy

Try it this way:

Sub CountColors()
Dim rAllRange As Range
Dim rAllRangeUsed As Range
Dim Cnt As Integer
Dim rCell As Range
Dim clr As String

On Error Resume Next
Set rAllRange = Intersect(Selection, Selection)
' Only examine the UsedRange
' portion of the selection
Set rAllRangeUsed = Intersect(ActiveSheet _
.UsedRange, rAllRange)
If rAllRange.Cells.Count < 2 Then
MsgBox "Your selection is not valid", vbInformation
On Error GoTo 0
Exit Sub
End If

Application.Calculation = xlCalculationManual

Cnt = 0
For Each rCell In rAllRangeUsed
If rCell.Interior.ColorIndex = ActiveCell.Interior.ColorIndex Then
Cnt = Cnt + 1
End If
Next rCell


If ActiveCell.Interior.ColorIndex = 1 Then
clr = "Black"
ElseIf ActiveCell.Interior.ColorIndex = 53 Then
clr = "Brown"
ElseIf ActiveCell.Interior.ColorIndex = 52 Then
clr = "Olive Green"
ElseIf ActiveCell.Interior.ColorIndex = 51 Then
clr = "Dark Green"
ElseIf ActiveCell.Interior.ColorIndex = 49 Then
clr = "Dark Teal"
ElseIf ActiveCell.Interior.ColorIndex = 11 Then
clr = "Dark Blue"
ElseIf ActiveCell.Interior.ColorIndex = 55 Then
clr = "Indigo"
ElseIf ActiveCell.Interior.ColorIndex = 56 Then
clr = "Gray [80%]"
ElseIf ActiveCell.Interior.ColorIndex = 9 Then
clr = "Dark Red"
ElseIf ActiveCell.Interior.ColorIndex = 46 Then
clr = "Orange"
ElseIf ActiveCell.Interior.ColorIndex = 12 Then
clr = "Dark yellow/Green"
ElseIf ActiveCell.Interior.ColorIndex = 10 Then
clr = "Green"
ElseIf ActiveCell.Interior.ColorIndex = 14 Then
clr = "Teal"
ElseIf ActiveCell.Interior.ColorIndex = 5 Then
clr = "Blue"
ElseIf ActiveCell.Interior.ColorIndex = 47 Then
clr = "Blue-Gray"
ElseIf ActiveCell.Interior.ColorIndex = 16 Then
clr = "Gray [50%]"
ElseIf ActiveCell.Interior.ColorIndex = 3 Then
clr = "Red"
ElseIf ActiveCell.Interior.ColorIndex = 45 Then
clr = "Light Orange"
ElseIf ActiveCell.Interior.ColorIndex = 43 Then
clr = "Lime Colored"
ElseIf ActiveCell.Interior.ColorIndex = 50 Then
clr = "Sea Green Colored"
ElseIf ActiveCell.Interior.ColorIndex = 42 Then
clr = "Aqua Colored"
ElseIf ActiveCell.Interior.ColorIndex = 41 Then
clr = "Light Blue"
ElseIf ActiveCell.Interior.ColorIndex = 13 Then
clr = "Violet"
ElseIf ActiveCell.Interior.ColorIndex = 48 Then
clr = "Gray [40%]"
ElseIf ActiveCell.Interior.ColorIndex = 7 Then
clr = "Pink"
ElseIf ActiveCell.Interior.ColorIndex = 44 Then
clr = "Gold Colored"
ElseIf ActiveCell.Interior.ColorIndex = 6 Then
clr = "Yellow"
ElseIf ActiveCell.Interior.ColorIndex = 4 Then
clr = "Bright Green"
ElseIf ActiveCell.Interior.ColorIndex = 8 Then
clr = "Turquoise"
ElseIf ActiveCell.Interior.ColorIndex = 33 Then
clr = "Sky Blue"
ElseIf ActiveCell.Interior.ColorIndex = 54 Then
clr = "Plum Colored"
ElseIf ActiveCell.Interior.ColorIndex = 15 Then
clr = "Gray [25%]"
ElseIf ActiveCell.Interior.ColorIndex = 38 Then
clr = "Rose Colored"
ElseIf ActiveCell.Interior.ColorIndex = 40 Then
clr = "Tan Colored"
ElseIf ActiveCell.Interior.ColorIndex = 36 Then
clr = "Light Yellow"
ElseIf ActiveCell.Interior.ColorIndex = 35 Then
clr = "Light Green"
ElseIf ActiveCell.Interior.ColorIndex = 34 Then
clr = "Light Turquoise"
ElseIf ActiveCell.Interior.ColorIndex = 37 Then
clr = "Pale Blue"
ElseIf ActiveCell.Interior.ColorIndex = 39 Then
clr = "Lavender Colored"
ElseIf ActiveCell.Interior.ColorIndex = 2 Then
clr = "White"
ElseIf ActiveCell.Interior.ColorIndex = -4142 Then
clr = "Uncolored"
Else
clr = "Other Colored"
End If


MsgBox "There Are " & Cnt & " " & clr & " Cells In Your Selection"



Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
End Sub

--
Regards,
Tom Ogilvy


MC82 said:
I am trying to practice writing macros by creating some of these from
scratch. I ran into a problem and I was hoping someone here could
help.

HERE IS HOW I CURRENTLY USE IT:
You select a region, then while holding down ctrl, click on the color
of the cell in the selection in which you would like to count. (if it
is the first cell you selected, you do not have to reselect the color)

The macro should come back with the color and the number of cells with
that color.

PROBLEM:
- This macro does not seem to display the correct count when I scroll
down the page a little and select the whole column (the colored cell i
want should be the first in the first visible row of the column)

- If I select the cells going from the bottom up, the count is
incorrect as well.


Code:
--------------------

Sub CountColors()
Dim rAllRange As Range
Dim aRange As Range
Dim strAdd As Range
Dim Cnt As Integer
Dim rCell As Range
Dim M1 As Boolean
Dim Clr As String
Dim bEntireColumn As Boolean
Dim bEntireRow As Boolean

With Selection
bEntireColumn = .Address = .EntireColumn.Address
bEntireRow = .Address = .EntireRow.Address
End With

On Error Resume Next
Set rAllRange = Selection

If rAllRange.Cells.Count < 2 Then
MsgBox "Your selection is not valid", vbInformation
On Error GoTo 0
Exit Sub
End If

Application.Calculation = xlCalculationManual

Cnt = 0
For Each rCell In rAllRange
If Cnt = 0 Then
If rCell.Address = ActiveCell.Address Then
M1 = True
Else
M1 = False
End If
End If

If rCell.Interior.ColorIndex = ActiveCell.Interior.ColorIndex Then
Cnt = Cnt + 1
End If
Next rCell

If ActiveCell.Interior.ColorIndex = 1 Then
Clr = "Black"
ElseIf ActiveCell.Interior.ColorIndex = 53 Then
Clr = "Brown"
ElseIf ActiveCell.Interior.ColorIndex = 52 Then
Clr = "Olive Green"
ElseIf ActiveCell.Interior.ColorIndex = 51 Then
Clr = "Dark Green"
ElseIf ActiveCell.Interior.ColorIndex = 49 Then
Clr = "Dark Teal"
ElseIf ActiveCell.Interior.ColorIndex = 11 Then
Clr = "Dark Blue"
ElseIf ActiveCell.Interior.ColorIndex = 55 Then
Clr = "Indigo"
ElseIf ActiveCell.Interior.ColorIndex = 56 Then
Clr = "Gray [80%]"
ElseIf ActiveCell.Interior.ColorIndex = 9 Then
Clr = "Dark Red"
ElseIf ActiveCell.Interior.ColorIndex = 46 Then
Clr = "Orange"
ElseIf ActiveCell.Interior.ColorIndex = 12 Then
Clr = "Dark yellow/Green"
ElseIf ActiveCell.Interior.ColorIndex = 10 Then
Clr = "Green"
ElseIf ActiveCell.Interior.ColorIndex = 14 Then
Clr = "Teal"
ElseIf ActiveCell.Interior.ColorIndex = 5 Then
Clr = "Blue"
ElseIf ActiveCell.Interior.ColorIndex = 47 Then
Clr = "Blue-Gray"
ElseIf ActiveCell.Interior.ColorIndex = 16 Then
Clr = "Gray [50%]"
ElseIf ActiveCell.Interior.ColorIndex = 3 Then
Clr = "Red"
ElseIf ActiveCell.Interior.ColorIndex = 45 Then
Clr = "Light Orange"
ElseIf ActiveCell.Interior.ColorIndex = 43 Then
Clr = "Lime Colored"
ElseIf ActiveCell.Interior.ColorIndex = 50 Then
Clr = "Sea Green Colored"
ElseIf ActiveCell.Interior.ColorIndex = 42 Then
Clr = "Aqua Colored"
ElseIf ActiveCell.Interior.ColorIndex = 41 Then
Clr = "Light Blue"
ElseIf ActiveCell.Interior.ColorIndex = 13 Then
Clr = "Violet"
ElseIf ActiveCell.Interior.ColorIndex = 48 Then
Clr = "Gray [40%]"
ElseIf ActiveCell.Interior.ColorIndex = 7 Then
Clr = "Pink"
ElseIf ActiveCell.Interior.ColorIndex = 44 Then
Clr = "Gold Colored"
ElseIf ActiveCell.Interior.ColorIndex = 6 Then
Clr = "Yellow"
ElseIf ActiveCell.Interior.ColorIndex = 4 Then
Clr = "Bright Green"
ElseIf ActiveCell.Interior.ColorIndex = 8 Then
Clr = "Turquoise"
ElseIf ActiveCell.Interior.ColorIndex = 33 Then
Clr = "Sky Blue"
ElseIf ActiveCell.Interior.ColorIndex = 54 Then
Clr = "Plum Colored"
ElseIf ActiveCell.Interior.ColorIndex = 15 Then
Clr = "Gray [25%]"
ElseIf ActiveCell.Interior.ColorIndex = 38 Then
Clr = "Rose Colored"
ElseIf ActiveCell.Interior.ColorIndex = 40 Then
Clr = "Tan Colored"
ElseIf ActiveCell.Interior.ColorIndex = 36 Then
Clr = "Light Yellow"
ElseIf ActiveCell.Interior.ColorIndex = 35 Then
Clr = "Light Green"
ElseIf ActiveCell.Interior.ColorIndex = 34 Then
Clr = "Light Turquoise"
ElseIf ActiveCell.Interior.ColorIndex = 37 Then
Clr = "Pale Blue"
ElseIf ActiveCell.Interior.ColorIndex = 39 Then
Clr = "Lavender Colored"
ElseIf ActiveCell.Interior.ColorIndex = 2 Then
Clr = "White"
ElseIf ActiveCell.Interior.ColorIndex = -4142 Then
Clr = "Uncolored"
Else
Clr = "Other Colored"
End If

If M1 = False Then
MsgBox "There Are " & Cnt - 1 & " " & Clr & " Cells In Your Selection"
Else
If bEntireColumn Then
MsgBox "There Are " & Cnt & " " & Clr & " Cells In Your Selection"
ElseIf bEntireRow Then
MsgBox "There Are " & Cnt - 1 & " " & Clr & " Cells In Your Selection"
Else
MsgBox "There Are " & Cnt & " " & Clr & " Cells In Your Selection"
End If

End If

Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
End Sub
Click to expand...
 
J

Jim Thomlinson

Here is a good reference on counting colours...

http://www.xldynamic.com/source/xld.ColourCounter.html
--
HTH...

Jim Thomlinson


MC82 said:
I am trying to practice writing macros by creating some of these from
scratch. I ran into a problem and I was hoping someone here could
help.

HERE IS HOW I CURRENTLY USE IT:
You select a region, then while holding down ctrl, click on the color
of the cell in the selection in which you would like to count. (if it
is the first cell you selected, you do not have to reselect the color)

The macro should come back with the color and the number of cells with
that color.

PROBLEM:
- This macro does not seem to display the correct count when I scroll
down the page a little and select the whole column (the colored cell i
want should be the first in the first visible row of the column)

- If I select the cells going from the bottom up, the count is
incorrect as well.


Code:
--------------------

Sub CountColors()
Dim rAllRange As Range
Dim aRange As Range
Dim strAdd As Range
Dim Cnt As Integer
Dim rCell As Range
Dim M1 As Boolean
Dim Clr As String
Dim bEntireColumn As Boolean
Dim bEntireRow As Boolean

With Selection
bEntireColumn = .Address = .EntireColumn.Address
bEntireRow = .Address = .EntireRow.Address
End With

On Error Resume Next
Set rAllRange = Selection

If rAllRange.Cells.Count < 2 Then
MsgBox "Your selection is not valid", vbInformation
On Error GoTo 0
Exit Sub
End If

Application.Calculation = xlCalculationManual

Cnt = 0
For Each rCell In rAllRange
If Cnt = 0 Then
If rCell.Address = ActiveCell.Address Then
M1 = True
Else
M1 = False
End If
End If

If rCell.Interior.ColorIndex = ActiveCell.Interior.ColorIndex Then
Cnt = Cnt + 1
End If
Next rCell

If ActiveCell.Interior.ColorIndex = 1 Then
Clr = "Black"
ElseIf ActiveCell.Interior.ColorIndex = 53 Then
Clr = "Brown"
ElseIf ActiveCell.Interior.ColorIndex = 52 Then
Clr = "Olive Green"
ElseIf ActiveCell.Interior.ColorIndex = 51 Then
Clr = "Dark Green"
ElseIf ActiveCell.Interior.ColorIndex = 49 Then
Clr = "Dark Teal"
ElseIf ActiveCell.Interior.ColorIndex = 11 Then
Clr = "Dark Blue"
ElseIf ActiveCell.Interior.ColorIndex = 55 Then
Clr = "Indigo"
ElseIf ActiveCell.Interior.ColorIndex = 56 Then
Clr = "Gray [80%]"
ElseIf ActiveCell.Interior.ColorIndex = 9 Then
Clr = "Dark Red"
ElseIf ActiveCell.Interior.ColorIndex = 46 Then
Clr = "Orange"
ElseIf ActiveCell.Interior.ColorIndex = 12 Then
Clr = "Dark yellow/Green"
ElseIf ActiveCell.Interior.ColorIndex = 10 Then
Clr = "Green"
ElseIf ActiveCell.Interior.ColorIndex = 14 Then
Clr = "Teal"
ElseIf ActiveCell.Interior.ColorIndex = 5 Then
Clr = "Blue"
ElseIf ActiveCell.Interior.ColorIndex = 47 Then
Clr = "Blue-Gray"
ElseIf ActiveCell.Interior.ColorIndex = 16 Then
Clr = "Gray [50%]"
ElseIf ActiveCell.Interior.ColorIndex = 3 Then
Clr = "Red"
ElseIf ActiveCell.Interior.ColorIndex = 45 Then
Clr = "Light Orange"
ElseIf ActiveCell.Interior.ColorIndex = 43 Then
Clr = "Lime Colored"
ElseIf ActiveCell.Interior.ColorIndex = 50 Then
Clr = "Sea Green Colored"
ElseIf ActiveCell.Interior.ColorIndex = 42 Then
Clr = "Aqua Colored"
ElseIf ActiveCell.Interior.ColorIndex = 41 Then
Clr = "Light Blue"
ElseIf ActiveCell.Interior.ColorIndex = 13 Then
Clr = "Violet"
ElseIf ActiveCell.Interior.ColorIndex = 48 Then
Clr = "Gray [40%]"
ElseIf ActiveCell.Interior.ColorIndex = 7 Then
Clr = "Pink"
ElseIf ActiveCell.Interior.ColorIndex = 44 Then
Clr = "Gold Colored"
ElseIf ActiveCell.Interior.ColorIndex = 6 Then
Clr = "Yellow"
ElseIf ActiveCell.Interior.ColorIndex = 4 Then
Clr = "Bright Green"
ElseIf ActiveCell.Interior.ColorIndex = 8 Then
Clr = "Turquoise"
ElseIf ActiveCell.Interior.ColorIndex = 33 Then
Clr = "Sky Blue"
ElseIf ActiveCell.Interior.ColorIndex = 54 Then
Clr = "Plum Colored"
ElseIf ActiveCell.Interior.ColorIndex = 15 Then
Clr = "Gray [25%]"
ElseIf ActiveCell.Interior.ColorIndex = 38 Then
Clr = "Rose Colored"
ElseIf ActiveCell.Interior.ColorIndex = 40 Then
Clr = "Tan Colored"
ElseIf ActiveCell.Interior.ColorIndex = 36 Then
Clr = "Light Yellow"
ElseIf ActiveCell.Interior.ColorIndex = 35 Then
Clr = "Light Green"
ElseIf ActiveCell.Interior.ColorIndex = 34 Then
Clr = "Light Turquoise"
ElseIf ActiveCell.Interior.ColorIndex = 37 Then
Clr = "Pale Blue"
ElseIf ActiveCell.Interior.ColorIndex = 39 Then
Clr = "Lavender Colored"
ElseIf ActiveCell.Interior.ColorIndex = 2 Then
Clr = "White"
ElseIf ActiveCell.Interior.ColorIndex = -4142 Then
Clr = "Uncolored"
Else
Clr = "Other Colored"
End If

If M1 = False Then
MsgBox "There Are " & Cnt - 1 & " " & Clr & " Cells In Your Selection"
Else
If bEntireColumn Then
MsgBox "There Are " & Cnt & " " & Clr & " Cells In Your Selection"
ElseIf bEntireRow Then
MsgBox "There Are " & Cnt - 1 & " " & Clr & " Cells In Your Selection"
Else
MsgBox "There Are " & Cnt & " " & Clr & " Cells In Your Selection"
End If

End If

Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
End Sub
Click to expand...
 
M

MC82

Thanks for trying to help guys. Didnt really get to the bottom of the
problem, but I did learn a few new things.
 

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

code wont compare negative numbers correctly 3
SUMPRODUCT and SUMIFS combined with Sumifbycolor (VBA code) 1
Colorindex 2 not formatting 7
Combine Two Different Worksheet_Change codes 9
Hide columns according to background fill color 2
"ElseIf c.Value = "X_Clear" Then" and "...Target.Cells.Count > 1"don't work 4
Change color in excel from access 1
Select a range based on Fill Color 9

Top