Excel现有连接新增行的VBA自定义函数结果重算优化需求

我在VBA模块中编写了自定义函数CalculateDueDate，用于带外部连接的表格列中。每次刷新连接时，全量计算耗时约10秒，希望仅针对新增记录重算函数结果以缩短耗时。原函数代码如下：

Public Function CalculateDueDate(StartDate As Date, HoursToAdd As Double, WorkdayStartHour As Double, WorkdayEndHour As Double, Holidays As Range) As Date
Dim DueDate As Date
Dim IsWorkday As Boolean
Dim Holiday As Range
Dim CurrentHour As Double
Dim RemainingHoursInDay As Double

' Initialize the due date
DueDate = StartDate

' Calculate the due date excluding non-working days
Do While HoursToAdd > 0
    ' Check if it's a workday
    IsWorkday = True

    ' Exclude weekends
    If Weekday(DueDate, vbMonday) > 5 Then
        IsWorkday = False
    End If

    ' Exclude holidays
    For Each Holiday In Holidays
        If DateValue(DueDate) = Holiday.Value Then
            IsWorkday = False
            Exit For
        End If
    Next Holiday

    If IsWorkday Then
        CurrentHour = DueDate - Int(DueDate) ' Decimal part of the date

        If CurrentHour < WorkdayStartHour Then
            DueDate = Int(DueDate) + WorkdayStartHour
        ElseIf CurrentHour >= WorkdayEndHour Then
            DueDate = Int(DueDate) + 1 + WorkdayStartHour
        Else
            RemainingHoursInDay = (WorkdayEndHour - CurrentHour) * 24

            If HoursToAdd <= RemainingHoursInDay Then
                DueDate = DueDate + (HoursToAdd / 24)
                HoursToAdd = 0
            Else
                DueDate = Int(DueDate) + 1 + WorkdayStartHour
                HoursToAdd = HoursToAdd - RemainingHoursInDay
            End If
        End If
    Else
        DueDate = Int(DueDate) + 1
    End If
Loop

CalculateDueDate = DueDate
End Function

解决方案 #

核心思路 #

通过给已计算完成的记录添加标记，避免每次刷新连接时重复计算已有数据的到期日，仅对新增的未标记记录执行计算逻辑。

步骤1：添加辅助标记列 #

在目标表格中新增一列，命名为IsCalculated，数据类型设置为布尔值（True/False），用于标记该行是否已经完成到期日计算。

步骤2：修改自定义函数 #

调整CalculateDueDate函数，加入标记判断逻辑：如果当前行已标记为计算完成，直接返回单元格现有值；未标记则执行计算，并标记为已完成。

Public Function CalculateDueDate(StartDate As Date, HoursToAdd As Double, WorkdayStartHour As Double, WorkdayEndHour As Double, Holidays As Range, IsCalculatedCell As Range) As Date
    ' 已计算完成则直接返回当前值，跳过计算逻辑
    If IsCalculatedCell.Value = True Then
        CalculateDueDate = Application.Caller.Value
        Exit Function
    End If

    Dim DueDate As Date
    Dim IsWorkday As Boolean
    Dim Holiday As Range
    Dim CurrentHour As Double
    Dim RemainingHoursInDay As Double

    ' 初始化到期日
    DueDate = StartDate

    ' 计算排除非工作日的到期日
    Do While HoursToAdd > 0
        IsWorkday = True

        ' 排除周末
        If Weekday(DueDate, vbMonday) > 5 Then
            IsWorkday = False
        End If

        ' 排除节假日
        For Each Holiday In Holidays
            If DateValue(DueDate) = Holiday.Value Then
                IsWorkday = False
                Exit For
            End If
        Next Holiday

        If IsWorkday Then
            CurrentHour = DueDate - Int(DueDate) ' 获取时间的小数部分（小时比例）

            If CurrentHour < WorkdayStartHour Then
                DueDate = Int(DueDate) + WorkdayStartHour
            ElseIf CurrentHour >= WorkdayEndHour Then
                DueDate = Int(DueDate) + 1 + WorkdayStartHour
            Else
                RemainingHoursInDay = (WorkdayEndHour - CurrentHour) * 24

                If HoursToAdd <= RemainingHoursInDay Then
                    DueDate = DueDate + (HoursToAdd / 24)
                    HoursToAdd = 0
                Else
                    DueDate = Int(DueDate) + 1 + WorkdayStartHour
                    HoursToAdd = HoursToAdd - RemainingHoursInDay
                End If
            End If
        Else
            DueDate = Int(DueDate) + 1
        End If
    Loop

    ' 标记当前行为已计算，关闭事件避免循环触发
    Application.EnableEvents = False
    IsCalculatedCell.Value = True
    Application.EnableEvents = True

    CalculateDueDate = DueDate
End Function

步骤3：调整表格公式调用 #

将原来的公式（例如=CalculateDueDate(A2,B2,C2,D2,$F$2:$F$10)）修改为：

=CalculateDueDate(A2,B2,C2,D2,$F$2:$F$10,E2)

其中E2为当前行对应的IsCalculated单元格。

步骤4：连接刷新后触发新增行计算 #

当外部连接刷新完成后，新增记录的IsCalculated列会为空值，此时函数会自动执行计算。若要确保仅触发新增行的计算，可以在工作簿的Workbook_AfterRefresh事件中添加逻辑：

Private Sub Workbook_AfterRefresh(ByVal Success As Boolean)
    If Success Then
        Dim tbl As ListObject
        ' 替换为你的工作表名和表格名
        Set tbl = ThisWorkbook.Worksheets("数据工作表").ListObjects("外部连接表格")
        Dim visibleRange As Range
        
        ' 筛选出未标记的新增行
        tbl.Range.AutoFilter Field:=tbl.ListColumns("IsCalculated").Index, Criteria1:=""
        
        ' 触发这些行的公式重算
        On Error Resume Next
        Set visibleRange = tbl.DataBodyRange.SpecialCells(xlCellTypeVisible)
        If Not visibleRange Is Nothing Then visibleRange.Calculate
        On Error GoTo 0
        
        ' 取消筛选
        tbl.Range.AutoFilter
    End If
End Sub

额外优化：节假日查询提速 #

原函数遍历节假日范围判断的方式在数据量大时效率较低，可以改用字典存储节假日，提升查询速度：

1. 先在模块顶部声明全局字典：

Private HolidayDict As Scripting.Dictionary

2. 添加初始化字典的子程序（可在工作簿打开时执行）：

Sub InitHolidayDict(Holidays As Range)
    Set HolidayDict = New Scripting.Dictionary
    Dim cell As Range
    For Each cell In Holidays
        If Not HolidayDict.Exists(DateValue(cell.Value)) Then
            HolidayDict.Add DateValue(cell.Value), True
        End If
    Next cell
End Sub

3. 修改函数中的节假日判断逻辑，替换原来的For Each循环：

' 替换原来的节假日判断循环
If HolidayDict.Exists(DateValue(DueDate)) Then
    IsWorkday = False
End If

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