Запустите функцию в режиме реального времени в Excel Macro

Question

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

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

Я уже пытаюсь запустить эту функцию

Application.CalculateFullRebuild

Но в реальном времени это не сработало, мне пришлось назначить эту функцию кнопке, и когда я хочу обновить ячейки, которые подсчитывают цвета, я нажимаю кнопку, но это не то, что я хочу. Я хочу, чтобы клетки подсчитывали цвета в реальном времени, я хочу, чтобы они показывали мне число сразу же, как я меняю цвет. Ячейка, которая считает цвет, имеет следующую формулу:

=COUNTCOLOR(A1;A1:A9998)

Где «A1» - это ячейка цвета, который я хочу, чтобы количество ячеек (например, образец), а «A1: A9998» - это диапазон, в котором я хочу, чтобы формула нашла цвет для предыдущего назначенного образца. Ячейка покажет количество ячеек в диапазоне с цветом образца.

Надеюсь, что предоставленная мною информация поможет вам дать хороший ответ:)

Большое спасибо!

Answer 1

Возможно, это не самое элегантное решение, но оно работает.Идея состоит в том, чтобы запускать Sub каждые 5-10 секунд, чтобы он работал в режиме реального времени.

Вот код:

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

Вставьте модуль класса и назовите его 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()
    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

В разделе ThisWorkbook вы положили:

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

Настройте свое имя листа и диапазон для отслеживания, после запуска события WorkBookopen будет отслеживаться ваш диапазон (ы), и изменение цвета пересчитает вашу функцию Countcolor (вы можете оставить application.volatile вне нее)