优化含Application.Volatile的VBA计算速度，解决函数更新失效问题

我太懂这种两难了——为了让自定义函数能跟着输入单元格自动更新加了Application.Volatile，结果整个工作簿卡到操作都费劲；删掉这句吧，函数又变成“死的”，输入改了也不更新。咱们来一步步解决这个问题，给你几个靠谱的方案：

方案1：移除Volatile，手动声明函数依赖（推荐VBA用户） #

Application.Volatile的问题在于它会让函数在任何单元格变化时都重新计算，哪怕变化的单元格和函数毫无关系。解决办法是告诉Excel：这个函数只依赖哪些特定的区域，只有这些区域变了才需要重新计算。

修改后的函数代码如下（保留你的核心逻辑，增加依赖声明）：

Private Function EstimateFunctions(ByVal calc As String, Optional ByVal repdate As Date)
    Dim rangeapproved As String
    Dim rangesum As String
    Dim depRanges As Range ' 用来存储函数依赖的所有区域
    Dim n As Integer
    Dim finalsum As Double
    finalsum = 0

    ' 第一步：收集所有函数可能用到的命名区域，让Excel追踪这些区域的变化
    On Error Resume Next ' 忽略不存在的命名区域
    For n = 1 To 10
        Set depRanges = Union( _
            depRanges, _
            Range("P" & n & "_RESOURCE_HOURS"), _
            Range("P" & n & "_APPROVAL"), _
            Range("P" & n & "_EXPENSE_QTY"), _
            Range("P" & n & "_ACTUALS_SUMMARY"), _
            Range("P" & n & "_ACTUALS_DATECOST"), _
            Range("P" & n & "_PERFORMANCE_SUMMARY"), _
            Range("P" & n & "_EARNED_VALUE"), _
            Range("P" & n & "_PERCENT_COMPLETE"), _
            Range("P" & n & "_BUDGET_SUMMARY"), _
            Range("P" & n & "_ACTUAL_EXPENSES") _
        )
    Next n
    Set depRanges = Union(depRanges, Range("SUMMARY_BUDGET"))
    On Error GoTo 0 ' 恢复错误处理

    ' 第二步：保留你的核心计算逻辑
    Select Case calc
        Case "SumHrs"
            For n = 1 To 10 Step 1
                rangesum = "P" & n & "_RESOURCE_HOURS"
                rangeapproved = "P" & n & "_APPROVAL"
                If Not RangeExists(rangesum) Then Exit For
                If Range(rangeapproved).Value = "Y" Then
                    temphrs = WorksheetFunction.Index(Range(rangesum), 0, _
                        Application.Caller.Column - (WorksheetFunction.Index(Range(rangesum), 0, 1).Column - 1))
                Else
                    temphrs = 0
                End If
                If temphrs = "-" Then temphrs = 0
                finalsum = finalsum + temphrs
            Next n
            If finalsum = 0 Then finalsum = ""
            EstimateFunctions = finalsum
        
        Case "SumQty"
            ' 保留你的SumQty逻辑...
        
        Case "SumActuals"
            ' 保留你的SumActuals逻辑...
        
        ' 其他Case依此类推，保留原逻辑即可
    End Select
End Function

为什么这个方案有效？ #

Excel会自动追踪depRanges里的所有区域，只有当这些区域的内容变化时，才会重新计算EstimateFunctions，而不是全局触发计算，既解决了自动更新问题，又大幅降低了计算量。

方案2：替换为Excel内置公式（最高效） #

如果可以放弃VBA，用Excel内置函数组合实现相同逻辑是最优解——内置函数的计算效率远高于VBA，而且天然支持自动更新。

以你的SumHrs逻辑为例，对应的单元格公式如下：

=IF(SUMPRODUCT(
    IF(ISREF(P1_APPROVAL),IF(P1_APPROVAL="Y",INDEX(P1_RESOURCE_HOURS,,COLUMN()-COLUMN(INDEX(P1_RESOURCE_HOURS,,1))+1),0),0),
    IF(ISREF(P2_APPROVAL),IF(P2_APPROVAL="Y",INDEX(P2_RESOURCE_HOURS,,COLUMN()-COLUMN(INDEX(P2_RESOURCE_HOURS,,1))+1),0),0),
    IF(ISREF(P3_APPROVAL),IF(P3_APPROVAL="Y",INDEX(P3_RESOURCE_HOURS,,COLUMN()-COLUMN(INDEX(P3_RESOURCE_HOURS,,1))+1),0),0),
    IF(ISREF(P4_APPROVAL),IF(P4_APPROVAL="Y",INDEX(P4_RESOURCE_HOURS,,COLUMN()-COLUMN(INDEX(P4_RESOURCE_HOURS,,1))+1),0),0),
    IF(ISREF(P5_APPROVAL),IF(P5_APPROVAL="Y",INDEX(P5_RESOURCE_HOURS,,COLUMN()-COLUMN(INDEX(P5_RESOURCE_HOURS,,1))+1),0),0),
    IF(ISREF(P6_APPROVAL),IF(P6_APPROVAL="Y",INDEX(P6_RESOURCE_HOURS,,COLUMN()-COLUMN(INDEX(P6_RESOURCE_HOURS,,1))+1),0),0),
    IF(ISREF(P7_APPROVAL),IF(P7_APPROVAL="Y",INDEX(P7_RESOURCE_HOURS,,COLUMN()-COLUMN(INDEX(P7_RESOURCE_HOURS,,1))+1),0),0),
    IF(ISREF(P8_APPROVAL),IF(P8_APPROVAL="Y",INDEX(P8_RESOURCE_HOURS,,COLUMN()-COLUMN(INDEX(P8_RESOURCE_HOURS,,1))+1),0),0),
    IF(ISREF(P9_APPROVAL),IF(P9_APPROVAL="Y",INDEX(P9_RESOURCE_HOURS,,COLUMN()-COLUMN(INDEX(P9_RESOURCE_HOURS,,1))+1),0),0),
    IF(ISREF(P10_APPROVAL),IF(P10_APPROVAL="Y",INDEX(P10_RESOURCE_HOURS,,COLUMN()-COLUMN(INDEX(P10_RESOURCE_HOURS,,1))+1),0),0)
)=0,"",SUMPRODUCT(
    IF(ISREF(P1_APPROVAL),IF(P1_APPROVAL="Y",INDEX(P1_RESOURCE_HOURS,,COLUMN()-COLUMN(INDEX(P1_RESOURCE_HOURS,,1))+1),0),0),
    IF(ISREF(P2_APPROVAL),IF(P2_APPROVAL="Y",INDEX(P2_RESOURCE_HOURS,,COLUMN()-COLUMN(INDEX(P2_RESOURCE_HOURS,,1))+1),0),0),
    IF(ISREF(P3_APPROVAL),IF(P3_APPROVAL="Y",INDEX(P3_RESOURCE_HOURS,,COLUMN()-COLUMN(INDEX(P3_RESOURCE_HOURS,,1))+1),0),0),
    IF(ISREF(P4_APPROVAL),IF(P4_APPROVAL="Y",INDEX(P4_RESOURCE_HOURS,,COLUMN()-COLUMN(INDEX(P4_RESOURCE_HOURS,,1))+1),0),0),
    IF(ISREF(P5_APPROVAL),IF(P5_APPROVAL="Y",INDEX(P5_RESOURCE_HOURS,,COLUMN()-COLUMN(INDEX(P5_RESOURCE_HOURS,,1))+1),0),0),
    IF(ISREF(P6_APPROVAL),IF(P6_APPROVAL="Y",INDEX(P6_RESOURCE_HOURS,,COLUMN()-COLUMN(INDEX(P6_RESOURCE_HOURS,,1))+1),0),0),
    IF(ISREF(P7_APPROVAL),IF(P7_APPROVAL="Y",INDEX(P7_RESOURCE_HOURS,,COLUMN()-COLUMN(INDEX(P7_RESOURCE_HOURS,,1))+1),0),0),
    IF(ISREF(P8_APPROVAL),IF(P8_APPROVAL="Y",INDEX(P8_RESOURCE_HOURS,,COLUMN()-COLUMN(INDEX(P8_RESOURCE_HOURS,,1))+1),0),0),
    IF(ISREF(P9_APPROVAL),IF(P9_APPROVAL="Y",INDEX(P9_RESOURCE_HOURS,,COLUMN()-COLUMN(INDEX(P9_RESOURCE_HOURS,,1))+1),0),0),
    IF(ISREF(P10_APPROVAL),IF(P10_APPROVAL="Y",INDEX(P10_RESOURCE_HOURS,,COLUMN()-COLUMN(INDEX(P10_RESOURCE_HOURS,,1))+1),0),0)
))

公式逻辑说明： #

• ISREF用来检查命名区域是否存在，避免不存在的区域导致公式错误
• INDEX根据当前单元格的列，取对应区域的同列数据
• SUMPRODUCT对符合条件（APPROVAL="Y"）的数值求和
• 外层IF把求和结果为0的情况转为空字符串，和你的VBA逻辑一致

其他Case（比如SumQty、SumActuals）可以参照这个逻辑修改公式，把对应的命名区域替换掉即可。

方案3：用Worksheet_Change事件触发手动更新 #

如果必须保留VBA函数，也可以通过工作表事件，在指定的输入单元格（比如E列）变化时，手动刷新函数所在的单元格。

在对应的工作表模块中添加以下代码：

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 监控E列的变化（可以根据你的实际需求修改范围）
    If Not Intersect(Target, Me.Range("E:E")) Is Nothing Then
        ' 方式1：刷新整个工作表的计算（简单但可能有点冗余）
        Me.Calculate
        
        ' 方式2：只刷新使用了EstimateFunctions的单元格（更精准）
        ' Dim cell As Range
        ' On Error Resume Next
        ' For Each cell In Me.Cells.SpecialCells(xlCellTypeFormulas)
        '     If InStr(cell.Formula, "EstimateFunctions") > 0 Then
        '         cell.Calculate
        '     End If
        ' Next cell
        ' On Error GoTo 0
    End If
End Sub

注意事项： #

• 这个方案需要确保你能准确监控所有会影响函数结果的输入单元格
• 如果输入范围很多，方式2比方式1更高效

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