如何为VBA自定义函数添加计数器 统计单元格数值变更次数

失效原因 #

你的代码无法生效有两个核心问题：

• Excel默认禁止用户自定义函数（UDF，可直接在单元格调用的Function）修改工作表的任意单元格内容，你在Bidcalcul里直接调用Compteur修改计数单元格的操作会被系统直接拦截
• 你使用ActiveCell获取当前行和初始值，而UDF运行时ActiveCell是用户当前选中的单元格，不是公式所在的单元格，只要用户切换了选中单元格，逻辑就会完全出错

可行实现方案 #

方案1：最小改动适配现有代码 #

无需大改你已有的逻辑，只需要修正两处问题即可生效：

Function Bidcalcul(Bid As Variant, Intervmin As Variant, Intervmax As Variant, Ticksize As Variant, Percentage As Variant) As Variant
    Dim rowcompteur As Integer
    Dim valeurinitial As Variant
    ' 用Application.Caller获取当前公式所在单元格，替代错误的ActiveCell
    With Application.Caller
        valeurinitial = .Value
        rowcompteur = .Row
    End With
    
    If IsError(Bid) Then
        Bidcalcul = WorksheetFunction.Floor(Bid * Percentage, Ticksize)
        Exit Function
    End If
    
    If Intervmin <= (Bid - valeurinitial) And (Bid - valeurinitial) <= Intervmax Then
        Bidcalcul = valeurinitial
    Else
        Bidcalcul = WorksheetFunction.Floor(Bid * Percentage, Ticksize)
        ' 用Evaluate绕过UDF不能修改工作表的限制，调用计数子程序
        Evaluate "Compteur(" & rowcompteur & ", 23)"
    End If
End Function

Private Sub Compteur(rowcompteur As Integer, column As Integer)
    ' 关闭事件避免循环触发，操作完成后恢复
    Application.EnableEvents = False
    Cells(rowcompteur, column).Value = Cells(rowcompteur, column).Value + 1
    Application.EnableEvents = True
End Sub

注意事项：

• 表格需要另存为.xlsm格式（启用宏的工作簿）
• Excel宏安全设置需要启用宏，否则代码不会运行

方案2：改用工作表事件实现（更适配Bloomberg实时数据场景） #

Bloomberg的实时数据更新会触发工作表Calculate事件，用事件实现没有UDF的权限限制，稳定性更高，不需要修改你已有的公式逻辑：

1. 首先保留你现有的Bidcalcul公式在单元格中正常使用
2. 双击VBA编辑器左侧对应工作表名称，粘贴以下代码即可：

' 模块顶部声明全局变量存储上一次的数值
Dim oldValues As Variant
Const MONITOR_COLUMN As Integer = 1 ' 请修改为你存放Bidcalcul公式的列号
Const COUNT_COLUMN As Integer = 23 ' 计数列号，和你原有逻辑一致

Private Sub Worksheet_Calculate()
    Dim i As Long, lastRow As Long
    Application.EnableEvents = False
    ' 获取监控列的最后一行数据
    lastRow = Cells(Rows.Count, MONITOR_COLUMN).End(xlUp).Row
    
    ' 首次运行初始化旧值数组
    If IsEmpty(oldValues) Then
        oldValues = Range(Cells(1, MONITOR_COLUMN), Cells(lastRow, MONITOR_COLUMN)).Value
        Application.EnableEvents = True
        Exit Sub
    End If
    
    ' 逐行对比新旧值，有变化则计数+1
    For i = 1 To lastRow
        If Cells(i, MONITOR_COLUMN).Value <> oldValues(i, 1) Then
            Cells(i, COUNT_COLUMN).Value = Cells(i, COUNT_COLUMN).Value + 1
            oldValues(i, 1) = Cells(i, MONITOR_COLUMN).Value
        End If
    Next i
    Application.EnableEvents = True
End Sub

内容的提问来源于stack exchange，提问作者HugoLny