Updating Count by Cell Color

[magneatooo]

HI all!

Admittedly, I'm terrible at Excel. I keep a spreadsheet for work and color code it. I found a formula via Google to count cells by color with a "key" I made to reference (i.e. I have a cell colored Yellow that said "Waiting for Verification") and then it counts how many are colored the cell in the key I referenced.

I need a way for the page to update -- when I change a cell from Yellow to Red, I need the total to update. Like if I change the cell that says "John Smith" from yellow to red, I need the yellow count to change from 29 to 28, etc. The "key" I made doesn't change.

Sorry if I'm babbling -- again, not very smart with Excel.

This is the code I'm using, which is really great for counting my cell colors. I just need to know what to add or update or whatever to update the counts.

Function CountCcolor(range_data As Range, criteria As Range) As Long
    Dim datax As Range
    Dim xcolor As Long
xcolor = criteria.Interior.ColorIndex
For Each datax In range_data
    If datax.Interior.ColorIndex = xcolor Then
        CountCcolor = CountCcolor + 1
    End If
Next datax
End Function

Anything to help I'd be forever grateful -- I'm seriously way in over my head and this is the first macro I've ever done LOL. Thank you!!

 

[Kenneth Hobson]

Changing colors does not trigger a change event. If you are using it as a UDF, you need a calculate event. You can force a recalc by Formulas > Calculate Now or changing a cell value manually.

 

[lrobbo314]

Could do something like this instead of a custom function.

Book1 (version 1).xlsb
	A	B	C	D
1	Status		Color	Count
2	Error		Error	8
3	Waiting for Verification		Waiting for Verification	11
4	Complete		Complete	6
5	Error
6	Waiting for Verification
7	Complete
8	Waiting for Verification
9	Error
10	Complete
11	Waiting for Verification
12	Waiting for Verification
13	Error
14	Complete
15	Complete
16	Error
17	Waiting for Verification
18	Error
19	Waiting for Verification
20	Error
21	Complete
22	Error
23	Waiting for Verification
24	Waiting for Verification
25	Waiting for Verification
26	Waiting for Verification
Sheet11

Sub COUNTCOLOR()
Dim SD As Object:   Set SD = CreateObject("Scripting.Dictionary")
Dim r As Range:     Set r = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
Dim c As Range
Dim s As String

For Each c In r
    s = Join(Array(c.Value, c.Interior.Color), ";")
    SD(s) = SD(s) + 1
Next c

Range("C1:D1").Value = Array("Color", "Count")
Set r = Range("C2")

For i = 0 To SD.Count - 1
    r.Value = Split(SD.keys()(i), ";")(0)
    r.Interior.Color = Split(SD.keys()(i), ";")(1)
    r.Offset(, 1).Value = SD.items()(i)
    Set r = r.Offset(1)
Next i
End Sub

 

[Jaafar Tribak]

The following ugly workaround might work if the UDF is not applied to many cells.

This workaround is meant to automatically update the UDF cell as soon as the color(s) are changed by the user.

Your UDF code becomes this :

Option Explicit

Private oCol As New Collection
Private cls As C_CountColors

Function CountCcolor(range_data As Range, CRITERIA As Range) As Long

    Dim datax As Range
    Dim xcolor As Long
 
    On Error Resume Next
 
    Set cls = New C_CountColors
    cls.Init range_data, CRITERIA, Range(Application.CALLER.Address)
    oCol.Add cls
 
    xcolor = CRITERIA.Interior.ColorIndex
    For Each datax In range_data
        If datax.Interior.ColorIndex = xcolor Then
            CountCcolor = CountCcolor + 1
        End If
    Next datax
 
End Function

Add a Class Module and give the class the name of C_CountColors
Put this code in the Class Module:

Option Explicit

Private rData As Range
Private rCriteria As Range
Private rCaller As Range
Private WithEvents cbars As CommandBars

Public Sub Init(ByVal rDataRange As Range, ByVal rCriteriaRange As Range, ByVal rCallerRange As Range)

    On Error Resume Next
 
    If rDataRange Is Nothing Then
        Application.CalculateFull
        Exit Sub
    End If
 
    Set rData = rDataRange
    Set rCriteria = rCriteriaRange
    Set rCaller = rCallerRange
    Set cbars = Application.CommandBars

End Sub

Private Sub cbars_OnUpdate()

    If CountCcolor(rData, rCriteria) <> rCaller.Value Then
        rCaller.Formula = rCaller.Formula
    End If
 
    With Application.CommandBars.FindControl(ID:=2020): .Enabled = Not .Enabled: End With
 
End Sub

And Finally, put the following in the ThisWorkbook Module:

Private Sub Workbook_Activate()
    Dim cl As New C_CountColors
    cl.Init Nothing, Nothing, Nothing
End Sub