在 Excel 宏上实时运行函数答案

【问题标题】：Run a function in real time on Excel Macro在 Excel 宏上实时运行函数
【发布时间】：2019-04-08 16:07:06
【问题描述】：

我需要一些想法来实时更新此功能。这个函数计算我需要的工作的单元格的颜色。

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”是我希望公式找到先前分配样本的颜色的范围。该单元格将显示该范围内的多个单元格以及样本的颜色。

我希望我提供的这些信息可以帮助您给我一个好的答案:)

非常感谢！

【问题讨论】：

没有由单元格颜色变化触发的内置“事件”。您需要从应用程序的消息队列中构建自己的。

标签： excel vba

【解决方案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

【讨论】：

计时器方法可能是最好的解决方法。这个解决方案可能会更整洁一些。 volatile 对子程序没有影响；如果没有外部数据，则不需要 RefreshAll；并且 COUNTCOLOR 应该是一个整数，如果没有匹配颜色的单元格，则默认返回 0。仅更新一个单元格的值时，也不需要关闭 ScreenUpdating。
这是一个非常好的解决方案，但由于我的要求，我认为不可行，非常感谢您为帮助我所做的努力。我想知道是否可以在我的原始代码中添加一些内容以使其每次使用“保存按钮”时再次运行（重新计算）您认为这可能吗？我认为这对我来说也是一个很好的解决方案！ ;)
那你就可以使用Workbook_BeforeSave事件了，下面我再贴一个解决办法

【解决方案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

调整您要监控的 Sheetname 和范围，在运行 WorkBookopen 事件后，您的范围将被监控并且颜色变化将重新计算您的 Countcolor 函数（您可以将 application.volatile 排除在外）

【讨论】：