Thanks, this seems very close to what I am aiming for. I want to count all
one color within the ranges. So it easy enough to remove one set of colors
in the code you gave me. However, I need it specified to only count the
specific colors in each count.

For instance, I need to know how many red cells in ranges ("B40:E58,
H32:K58" etc.) and how many yellow in the same ranges. I also would like the
results on a new page I will set and format. If we use "Sheet2" Cells
(A2:Z2) for an easy destination reference I can customize the exact
destinations later. Maybe i just am not Debugging Print line correctly?

Thanks for your time,
Clint



"Peter T" wrote:

Hello again,

If I follow you want to return fills in upt to 5 areas. Following should get
them all in one go.

Not sure how you want to report the info, as written look at the immediate
window, Ctrl-g

Sub GetFills()
' only count once per merged area
Dim x As Long, i As Long, a As Long
Dim redCells As Long
Dim yellowCells As Long
Dim rng As Range, aR As Range, c As Range

Set rng = Range("B40:E58, H32:K58") ' add more areas here
' address length MUST be <256

ReDim aIdx(1 To rng.Areas.Count, 1 To 56) As Long
For Each aR In rng.Areas
a = a + 1
For Each c In aR
x = c.Interior.ColorIndex
If x = 0 Then
If c.MergeCells Then
If c.Address = c.MergeArea(1, 1).Address Then
aIdx(a, x) = aIdx(a, x) + 1
End If
Else
aIdx(a, x) = aIdx(a, x) + 1
End If
End If
Next
Next

For a = 1 To rng.Areas.Count
Debug.Print rng.Areas(1).Address(0, 0)
For i = 1 To 56
If aIdx(a, i) Then
Debug.Print a, i, aIdx(a, i)
End If
Next
Next

End Sub

Regards,
Peter T

"Whois Clinton" wrote in message
...
Hi All,

I am currently counting colored cells, some are merged being counted as
one.
I have 5 colors to count in 26 different ranges all on 1 sheet. Currently
I
have a seperate macro to run for each seperate color in each of the 26
ranges. Each result is displayed in a MsgBox. I would like to condense
these macros to run in groups by color. For instance count all of the
yellow
cells within the 26 different ranges. Then instead of a MsgBox I would
like
to results on a seperate sheet somehow. This way I can preformat the
results
sheet to indicate the range then the answer can go in the cell next to it.
Given a simple sample destination I can modify it to my spefic settings.
I
am not fluent in macro so some guidance is appreciated.

Below are two of the macros for reference:

Option Explicit
Sub zwCoopReinYellow()
Dim c As Range
Dim MyRange As Range
Dim arrRng() As String
Dim yellowCells As Long
Dim N As Long
Dim M As Long

Set MyRange = Range("B40:E58")
ReDim arrRng(1 To MyRange.Count)

For Each c In MyRange
If c.Interior.ColorIndex = 6 Then
If c.MergeCells Then
N = N + 1
For M = 1 To N
If c.MergeArea.Address = arrRng(M) Then
Exit For
End If
Next
If M N Then
yellowCells = yellowCells + 1
arrRng(N) = c.MergeArea.Address
End If
Else
yellowCells = yellowCells + 1
End If
End If
Next
MsgBox yellowCells, vbOKOnly, "Coop Rein Yellow"
Set c = Nothing
Set MyRange = Nothing
End Sub
__________________________________________________ _______________


Option Explicit
Sub zyVisualYellow()
Dim c As Range
Dim MyRange As Range
Dim arrRng() As String
Dim yellowCells As Long
Dim N As Long
Dim M As Long

Set MyRange = Range("H32:K58")
ReDim arrRng(1 To MyRange.Count)

For Each c In MyRange
If c.Interior.ColorIndex = 6 Then
If c.MergeCells Then
N = N + 1
For M = 1 To N
If c.MergeArea.Address = arrRng(M) Then
Exit For
End If
Next
If M N Then
yellowCells = yellowCells + 1
arrRng(N) = c.MergeArea.Address
End If
Else
yellowCells = yellowCells + 1
End If
End If
Next
MsgBox yellowCells, vbOKOnly, "Visual Yellow"
Set c = Nothing
Set MyRange = Nothing
End Sub

__________________________________________________ ___________

Thanks SO much
Clint