每20秒自动刷新工作表条件格式的问题求助

问题背景 #

我有一张学校每日课程时段工作表，需要每20秒成对列应用条件格式：

• 第一节课8:10（B3）开始，8:55（C3）结束，当前时间处于该区间时高亮B2:C3区域
• 时间超过C3不超过20秒时切换条件格式
• 工作表包含3种课程表，由以下单元格控制：
  • H1：周一/周二/周四/周五课程表，公式=IF(J1="N","Y","N")，默认值"Y"
  • J1：周三课程表，公式=IF(WEEKDAY(TODAY())=4,"Y","N")
  • L1：延迟开学雪天课程表，值为"Y"/"N"

核心问题：条件格式不会自动更新，必须切换到其他工作表再切回"Schedule"才生效，此时格式工作正常。

现有设置 #

• VBA属性中EnableFormatConditionsCalculation已设为True
• 公式计算选项已设为自动计算

现有条件格式公式示例 #

• B2:C2（合并单元格）：

  =IF(OR(AND(J1="N",TIME(HOUR(NOW()),MINUTE(NOW()),SECOND(NOW())) >= B3, TIME(HOUR(NOW()),MINUTE(NOW()),SECOND(NOW())) < C3),AND(J1="Y",TIME(HOUR(NOW()),MINUTE(NOW()),SECOND(NOW())) >= B4, TIME(HOUR(NOW()),MINUTE(NOW()),SECOND(NOW())) < C4),AND(L1="Y",TIME(HOUR(NOW()),MINUTE(NOW()),SECOND(NOW())) >= B5, TIME(HOUR(NOW()),MINUTE(NOW()),SECOND(NOW())) < C5)), TRUE, FALSE)
  

• B3：

  =AND(J1="N",TIME(HOUR(NOW()),MINUTE(NOW()),SECOND(NOW())) >= B3, TIME(HOUR(NOW()),MINUTE(NOW()),SECOND(NOW())) < C3)
  

• C3：

  =AND(J1="N",TIME(HOUR(NOW()),MINUTE(NOW()),SECOND(NOW())) >= B3, TIME(HOUR(NOW()),MINUTE(NOW()),SECOND(NOW())) < C3)
  

现有VBA代码 #

Schedule工作表（Sheet12）代码 #

Private Sub Worksheet_Activate()
    RecalculateWorkingHours
    With Application
        .EnableEvents = True
        .OnTime earliesttime:=Now + TimeValue("00:00:20"), procedure:="Refresh_Schedule", Schedule:=True
    End With
End Sub

ThisWorkbook代码 #

Public Sub Workbook_Open()
    RecalculateWorkingHours
End Sub

Module2代码 #

Public Sub RecalculateWorkingHours()
    Dim T1 As Date
    Dim T2 As Date
    Dim x  As Variant
    T0 = Now
    T1 = TimeValue("8:00 AM")
    T2 = TimeValue("3:31 PM")
    If T0 >= T1 And T0 <= T2 Then
        Calculate
        Application.OnTime earliesttime:=Now + TimeValue("00:00:20"), procedure:="RecalculateWorkingHours" ', schedule:=False
    Else
    End If
End Sub

Public Sub Refresh_Schedule()
    Calculate
End Sub

解决方法 #

问题根源在于仅调用Calculate无法强制刷新条件格式，需要直接触发条件格式的重新计算。修改代码如下：

1. 更新Module2中的代码 #

Public Sub RecalculateWorkingHours()
    Dim T0 As Date
    Dim T1 As Date
    Dim T2 As Date
    T0 = Now
    T1 = TimeValue("8:00 AM")
    T2 = TimeValue("3:31 PM")
    If T0 >= T1 And T0 <= T2 Then
        ' 强制刷新Schedule工作表的条件格式
        With ThisWorkbook.Worksheets("Schedule")
            .EnableFormatConditionsCalculation = False
            .EnableFormatConditionsCalculation = True
        End With
        Calculate
        ' 重新调度下一次执行
        Application.OnTime earliesttime:=Now + TimeValue("00:00:20"), procedure:="RecalculateWorkingHours"
    End If
End Sub

Public Sub Refresh_Schedule()
    ' 强制刷新Schedule工作表的条件格式
    With ThisWorkbook.Worksheets("Schedule")
        .EnableFormatConditionsCalculation = False
        .EnableFormatConditionsCalculation = True
    End With
    Calculate
End Sub

2. 修复Schedule工作表的激活事件代码 #

避免重复调度任务，保留核心逻辑：

Private Sub Worksheet_Activate()
    RecalculateWorkingHours
    Application.EnableEvents = True
End Sub

3. 优化条件格式公式（可选） #

简化冗余的时间转换逻辑，提升计算效率：

• B2:C2公式修改为：

  =OR(AND(J1="N",NOW()-TODAY()>=B3,NOW()-TODAY()<C3),AND(J1="Y",NOW()-TODAY()>=B4,NOW()-TODAY()<C4),AND(L1="Y",NOW()-TODAY()>=B5,NOW()-TODAY()<C5))
  

• B3和C3公式修改为：

  =AND(J1="N",NOW()-TODAY()>=B3,NOW()-TODAY()<C3)
  

原理说明 #

• 切换工作表时Excel会自动重新计算条件格式，但后台仅调用Calculate不会触发该动作
• 通过先关闭再开启EnableFormatConditionsCalculation，可强制Excel重新评估所有条件格式规则
• 简化公式能减少计算负载，提升整体刷新效率

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