Multiple Macros at once different output

[Whois Clinton]

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

 

[Whois Clinton]

One clarification... I need each a total for each specific range not a grand
total.
Thanks again,
Clint

 

[Peter T]

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]

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]

No need to "remove one set of colors", just get the ones you want to know
about from the array "aIdx", eg

After the debug code (comment or remove if you want) add the following

Dim wsReport As Worksheet
Dim arrReqdClrs, arrClrNames ' variants

Set ws = Worksheets("Sheet2") ' << CHANGE
arrReqdClrs = Array(3, 6)
arrClrNames = Array("Red", "Yellow")


ws.Range("A1") = ActiveSheet.Name
For a = 1 To rng.Areas.Count
ws.Cells(1, a + 1) = rng.Areas(a).Address(0, 0)
Next

For i = 0 To UBound(arrReqdClrs)
ws.Cells(i + 2, 1) = arrClrNames(i)
For a = 1 To rng.Areas.Count
ws.Cells(i + 2, a + 1) = aidx(a, arrReqdClrs(i))
Next
Next

Add more ColorIndexes and names to the arrays arrReqdClrs & arrClrNames as
you're interested in (ensure each array has same qty of elements).

Regards,
Peter T

 

[Whois Clinton]

AWESOME Thank you so much. You have saved me (and my eyes) days of
counting!!!
Clint