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

也许这不是最优雅的解决方案，但它确实有效。这个想法是每5-10秒运行一次Sub，以使其实时工作。

代码如下：

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保留在其中）

在Excel Macro上实时运行功能

2 个答案: