CODEWITHSUNDEEP
excelvba
hsquared
hsquared

Reputation: 359

Getting VBA Function to auto update when a change is made on sheet - excel

I have a VBA function which counts cells of a certain colour:

Function CountCellsByColor(rData As Range, cellRefColor As Range) As Long
Dim indRefColor As Long
Dim cellCurrent As Range
Dim cntRes As Long

Application.Volatile
cntRes = 0
indRefColor = cellRefColor.Cells(1, 1).Interior.Color
For Each cellCurrent In rData
    If cellCurrent.Value > 0 Then
        If indRefColor = cellCurrent.Interior.Color Then
        cntRes = cntRes + 1
        End If
    End If
Next cellCurrent

CountCellsByColor = cntRes
End Function

My problem is that this doesn't update when changes are made on the sheet (only when F9 is pressed) - I'm new to VBA and would like it to auto update/execute the function when any change happens on the sheet. I'm sure there are many ways to do this but a bit stuck on how to actually achieve it.

Thanks in advance!

Upvotes: 3

Views: 16585

Answers (2)

EvR
EvR

Reputation: 3498

CommandBars.OnUpdate Event example:

In a Module: Your function but leave Application.Volatile out of it In a Class named: "ClsMonitorOnupdate" :

 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()
Dim cl As Range
On Error GoTo einde
    If ActiveWorkbook.Name <> ThisWorkbook.Name Then Exit Sub
    If ActiveSheet.Name <> rMonitor.Parent.Name Then Exit Sub
    If TypeName(Selection) <> "Range" Then Exit Sub
    If Intersect(Selection, rMonitor) Is Nothing Then Exit Sub
        For Each cl In Selection
            cl.Dirty
        Next cl
einde:

End Sub

In the ThisWorkBook Module:

Option Explicit
Private sRanges As String
Private cMonitor As ClsMonitorOnupdate
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Set cMonitor = Nothing
End Sub
Private Sub Workbook_Open()
  Zetaan ActiveSheet
End Sub
Sub Zetuit()
 Set cMonitor = Nothing
End Sub
Sub Zetaan(sht As Worksheet)
    Select Case sht.Name
        Case "Sheet1": sRanges = "A1:A10, B5:C12" 'adjust Sheetnames and monitor-range
        Case "Sheet2": sRanges = "A1:A10"
        Case Else: Exit Sub
    End Select
     Set cMonitor = New ClsMonitorOnupdate
    Set cMonitor.Range = Sheets(sht.Name).Range(sRanges)
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Zetaan Sh
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
Set cMonitor = Nothing
End Sub

Adjust to Your SheetNames and Range(s) in the Sub Zetaan (At least the range(s) your function is referring to)

Upvotes: 2

Axel Richter
Axel Richter

Reputation: 61862

If you are sure that the sheet has not as much amount of formulas that recalculating on every selection change leads to an crash, then the following would be possible:

The Application.Volatile in your function already leads to "update when changes are made on the sheet" which triggers recalculation. Problem is that changing a color is not the kind of changing which triggers recalculation.

So do a 

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 Me.Calculate
End Sub

into the SheetN VBA module.

This leads to recalculating on every selection change in that sheet. And because your function is volatile already this also will be recalculated then.

Upvotes: 3

Related Questions