Run a function in real time on Excel Macro - excel

Question

I need some idea to make this function update in real time. This function count the color of the cells for a work I need.
Function COUNTCOLOR(celdaOrigen As Range, rango As Range)
Application.Volatile
Dim celda As Range
For Each celda In rango
If celda.Interior.Color = celdaOrigen.Interior.Color Then
COUNTCOLOR = COUNTCOLOR + 1
End If
Next celda
End Function
I already try to run this function
Application.CalculateFullRebuild
But It didn't work in real time, I had to assign that function to a button and when I want to update the cells which count the colors I press the button, but that's not what I want. I want the cells count the colors in real time, I want they show me the number immediately I change a color. The cell that count the color has the following formula:
=COUNTCOLOR(A1;A1:A9998)
Where "A1" is a cell of the color I want the cell counts (like a sample), and the "A1:A9998" is the range where I want the formula find the color a the previous assigned sample. The cell will show a number of the cells in the range with the color of the sample.
I hop this information I provided can help you to give me a good answer :)
Thank you so much!

Answer 1

Perhaps, it's not the most elegant solution, but it works. The idea is to run the Sub every 5-10 seconds to make it work in real time.
Here is the code:
Sub COUNTCOLOR()
Dim RunTime
Dim COUNTCOLOR As Integer
Dim celda As Range
Dim lastRow As Variant
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Dim rango As Range
Set rango = Range("A1:A" & lastRow)
For Each celda In rango
'Compare cell interior color with cell A1
If celda.Interior.Color = Cells(1, "A").Interior.Color Then
COUNTCOLOR = COUNTCOLOR + 1
End If
Cells(1, "C").Value = COUNTCOLOR
Next celda
'To run sub every 5 seconds
RunTime = Now + TimeValue("00:00:05")
Application.OnTime RunTime, "COUNTCOLOR"
End Sub

Answer 2

Insert a class module and name it ClsMonitorOnupdate
Put in the code below
Option Explicit
Private WithEvents objCommandBars As Office.CommandBars
Private rMonitor As Range
Public Property Set Range(ByRef r As Range): Set rMonitor = r: End Property
Public Property Get Range() As Range: Set Range = rMonitor: End Property
Private Sub Class_Initialize()
Set objCommandBars = Application.CommandBars
End Sub
Private Sub Class_Terminate()
Set objCommandBars = Nothing
End Sub
Private Sub objCommandBars_OnUpdate()
If ActiveWorkbook.Name <> ThisWorkbook.Name Then Exit Sub
If TypeName(Selection) <> "Range" Then Exit Sub
If Intersect(Selection, rMonitor) Is Nothing Then Exit Sub
rMonitor.Dirty 'dosomething to trigger your function
End Sub
In the ThisWorkbooksection you put:
Option Explicit
Private Const sRanges As String = "A1:A100" 'adjust to your range Rango?
Private Const sSheet As String = "YourSheetName" 'adjust to your sheetname
Private cMonitor As ClsMonitorOnupdate
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set cMonitor = Nothing
End Sub
Private Sub Workbook_Open()
Set cMonitor = New ClsMonitorOnupdate
Set cMonitor.Range = Sheets(sSheet).Range(sRanges)
End Sub
Adjust your Sheetname and range to monitor, after running the WorkBookopen event your range(s) will be monitored and a color-change will recalculate your Countcolor function (you can leave application.volatile out of it)