Updating Count by Cell Color

magneatooo

New Member
Joined
Apr 14, 2021
Messages
1
Office Version
  1. 365
Platform
  1. Windows
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.

VBA Code:
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!!
 

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result

Kenneth Hobson

Well-known Member
Joined
Feb 6, 2007
Messages
3,180
Office Version
  1. 365
Platform
  1. Windows
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

Well-known Member
Joined
Jul 14, 2008
Messages
3,337
Office Version
  1. 365
Platform
  1. Windows
Could do something like this instead of a custom function.

Book1 (version 1).xlsb
ABCD
1StatusColorCount
2ErrorError8
3Waiting for VerificationWaiting for Verification11
4CompleteComplete6
5Error
6Waiting for Verification
7Complete
8Waiting for Verification
9Error
10Complete
11Waiting for Verification
12Waiting for Verification
13Error
14Complete
15Complete
16Error
17Waiting for Verification
18Error
19Waiting for Verification
20Error
21Complete
22Error
23Waiting for Verification
24Waiting for Verification
25Waiting for Verification
26Waiting for Verification
Sheet11


VBA Code:
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

Well-known Member
Joined
Dec 5, 2002
Messages
8,381
Office Version
  1. 2016
Platform
  1. Windows
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 :
VBA Code:
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:
VBA Code:
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:
VBA Code:
Private Sub Workbook_Activate()
    Dim cl As New C_CountColors
    cl.Init Nothing, Nothing, Nothing
End Sub
 

Forum statistics

Threads
1,147,823
Messages
5,743,409
Members
423,792
Latest member
travisds

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top