Получение функции VBA для автоматического обновления при внесении изменений на листе - Excel

Question

У меня есть функция VBA, которая подсчитывает ячейки определенного цвета:

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

Моя проблема заключается в том, что это не обновляется при внесении изменений на листе (только когда нажата клавиша F9) - я новичок в VBA и хотел бы, чтобы он автоматически обновлял / выполнял функцию, когда любое изменение происходит на простынь. Я уверен, что есть много способов сделать это, но немного застрял на том, как на самом деле достичь этого.

Заранее спасибо!

Answer 1

CommandBars.OnUpdate Пример события:

В модуле: Вы работаете, но не используете Application.Volatile В классе с именем: "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

В модуле ThisWorkBook:

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

Настройтесь на свои имена и диапазон (ы) в Зетане (По крайней мере, диапазон (ы), к которым относится ваша функция)

Answer 2

Если вы уверены, что на листе не так много формул, что пересчет при каждом изменении выбора приводит к сбою, тогда возможно следующее:

Application.Volatile в вашей функции уже приводит к «обновлению при внесении изменений в лист», что вызывает пересчет. Проблема в том, что изменение цвета - это не то изменение, которое вызывает пересчет.

Так же, как и

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

в SheetN модуль VBA.

Это приводит к пересчету при каждом изменении выбора на этом листе. А поскольку ваша функция уже изменчива, она также будет пересчитана.