Excel VBA：F列公式返回指定结果时H列无法自动填充日期问题

需要通过VBA实现：F列（Result列）内容为Preferred或Non-preferred时，同行H列（Date列）自动填充当前日期；F列清空时H列同步清空。当前功能存在两类表现：

• 手动在F列单元格输入Preferred或Non-preferred后按回车，H列可正常填充当日日期，该场景逻辑正常
• F列粘贴公式（公式根据A-E列数据计算返回结果）时，即使公式计算结果为Preferred或Non-preferred，H列也不会自动填充日期；只有逐一双击F列对应单元格按回车后，日期才会正常显示

当前使用的VBA代码如下：

Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
Dim St As String
St = "Preferred|Non-Preferred"
If Not Intersect(Columns("F"), Target) Is Nothing Then
    Application.EnableEvents = False
    For Each c In Intersect(Columns("F"), Target).Cells
        If InStr(1, St, c.Value, vbTextCompare) >= 1 Then
            Cells(c.Row, "H").Value = Date
        Else
            If IsEmpty(c) Then Cells(c.Row, "H").Value = ""
        End If
    Next c
    Application.EnableEvents = True
End If
End Sub

问题示例截图：

Worksheet_Change事件仅在单元格被手动编辑、粘贴值/粘贴公式的操作瞬间触发，不会响应公式计算完成后的单元格值变更：

• 手动输入值时，事件触发时单元格已经是最终输入的文本值，可以正常匹配规则
• 粘贴公式时，事件触发在公式完成计算之前，此时读取到的F列单元格内容不是最终计算结果，无法匹配Preferred/Non-preferred规则，因此不会触发日期填充
• 双击单元格按回车的操作，会强制单元格完成计算后再触发Change事件，此时能读取到最终值，因此功能临时恢复正常

需要同时保留Worksheet_Change处理手动输入场景，新增Worksheet_Calculate事件响应公式计算后的结果变更，修复后完整代码如下：

' 定义需要匹配的关键词常量，方便后续维护
Const MATCH_TEXT As String = "Preferred|Non-Preferred"

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim checkRng As Range, c As Range
    ' 仅处理F列的变更
    Set checkRng = Intersect(Columns("F"), Target)
    If Not checkRng Is Nothing Then
        Application.EnableEvents = False
        For Each c In checkRng.Cells
            Call UpdateDateCell(c)
        Next c
        Application.EnableEvents = True
    End If
End Sub

Private Sub Worksheet_Calculate()
    Dim c As Range
    Dim lastRow As Long
    ' 获取F列最后一行有内容的行号，避免全列遍历降低效率
    lastRow = Cells(Rows.Count, "F").End(xlUp).Row
    If lastRow < 2 Then Exit Sub ' 假设表头在第1行，无有效数据时直接退出
    Application.EnableEvents = False
    ' 遍历F列所有有内容的单元格，处理公式计算后的结果匹配
    For Each c In Range("F2:F" & lastRow).Cells
        Call UpdateDateCell(c)
    Next c
    Application.EnableEvents = True
End Sub

' 抽离公共的日期更新逻辑，避免重复代码
Private Sub UpdateDateCell(sourceCell As Range)
    If InStr(1, MATCH_TEXT, sourceCell.Value, vbTextCompare) >= 1 Then
        ' 仅当H列当前为空时才填充日期，避免后续打开文件时日期被更新为最新日期
        If IsEmpty(sourceCell.Offset(0, 2).Value) Then
            sourceCell.Offset(0, 2).Value = Date
        End If
    ElseIf IsEmpty(sourceCell.Value) Then
        sourceCell.Offset(0, 2).Value = ""
    End If
End Sub

注意：代码中增加了判断逻辑，仅当H列为空时才写入日期，避免后续表格重算时原有日期被覆盖为当天日期，符合填表留痕的常规需求。如果需要每次结果变化都更新日期，删掉对应判断即可。

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