Windows11下Excel的Application.OnTime无交互延迟问题求助

问题现象 #

使用Microsoft 365 Excel的Application.OnTime实现每秒重复任务时，无用户交互状态下任务会出现逐渐增大的延迟：

• 运行Start()后无操作，从Count=10开始延迟4秒
• Count=20开始延迟扩大到19秒并持续
• 执行任何改变Excel状态的操作（移动单元格、切换窗口焦点等），延迟会立即消失

复现代码 #

Option Explicit

Private Count As Long

Sub Start()
    Count = 1
    Application.OnTime DateAdd("s", 2, Time), "Routine"
End Sub

Sub Routine()
    Dim tm
    tm = Time
    Debug.Print "Count:" & Count & "    now:" & tm
    ThisWorkbook.Worksheets(1).Cells(1, 1) = Count
    tm = DateAdd("s", 1, tm)
    Application.OnTime tm, "Routine"
    Count = Count + 1
    Debug.Print "           next:" & tm
    Debug.Print "----------------------------"
End Sub

调试输出示例 #

Count:1    now:5:27:42
           next:5:27:43
----------------------------
Count:2    now:5:27:43
           next:5:27:44
----------------------------
...
Count:9    now:5:27:50
           next:5:27:51
----------------------------
Count:10    now:5:27:55     ← 4-second delay began
           next:5:27:56
----------------------------
...
Count:19    now:5:28:40
           next:5:28:41
----------------------------
Count:20    now:5:29:00     ← 19-second delay began
           next:5:29:01
----------------------------
...

环境测试结果 #

• Windows 11 Pro 24H2 → 出现延迟
• Windows 11 Pro 23H2 → 出现延迟
• Windows 11 Home 23H2（从Windows10升级）→ 运行正常
• Windows 10 Home 22H2 → 运行正常

问题原因 #

该问题是Windows 11全新安装的Pro版本系统节能策略导致：当Excel长时间无交互时，系统会降低其后台进程优先级，使得Application.OnTime的定时触发被系统延迟调度。升级而来的Windows 11 Home和Windows 10保留了旧的进程调度逻辑，因此未出现此问题。

解决方法与替代方案 #

1. 调整Excel进程优先级 #

• 临时生效：打开任务管理器，找到EXCEL.EXE，右键→设置优先级→高于正常或高
• 永久生效：通过批处理启动Excel，脚本如下：

  start "" /high "C:\Program Files\Microsoft Office\root\Office16\EXCEL.EXE"
  

  注：路径需根据你的Office安装位置调整

2. 禁用Excel电池优化 #

• 打开Windows设置→系统→电源和电池→电池优化
• 找到Microsoft Excel，设置为不允许优化电池使用

3. VBA代码中添加强制刷新逻辑 #

在Routine过程中加入一行强制UI刷新的代码，避免系统判定Excel为无活动进程：

Sub Routine()
    Dim tm
    tm = Time
    Debug.Print "Count:" & Count & "    now:" & tm
    ThisWorkbook.Worksheets(1).Cells(1, 1) = Count
    
    ' 强制刷新UI，防止系统降低进程优先级
    Application.ScreenUpdating = True
    
    tm = DateAdd("s", 1, tm)
    Application.OnTime tm, "Routine"
    Count = Count + 1
    Debug.Print "           next:" & tm
    Debug.Print "----------------------------"
End Sub

若已开启ScreenUpdating，可替换为DoEvents（注意：DoEvents会让代码响应其他用户操作，需根据场景选择）

4. 使用Windows定时器API替代Application.OnTime #

通过Windows原生API实现更可靠的定时，不受Excel进程状态影响：

Option Explicit

Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private TimerID As LongPtr
Private Count As Long

Sub Start()
    Count = 1
    ' 设置1000ms（1秒）定时器
    TimerID = SetTimer(0, 0, 1000, AddressOf TimerProc)
End Sub

Sub StopTimer()
    If TimerID <> 0 Then
        KillTimer 0, TimerID
        TimerID = 0
    End If
End Sub

Private Sub TimerProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As Long)
    Count = Count + 1
    Debug.Print "Count:" & Count & "    now:" & Time
    ThisWorkbook.Worksheets(1).Cells(1, 1) = Count
End Sub

注意事项：

• 工作簿关闭时需调用StopTimer避免内存泄漏，可在ThisWorkbook中添加：

  Private Sub Workbook_BeforeClose(Cancel As Boolean)
      StopTimer
  End Sub
  

• 此方法定时精度更高，不受系统节能策略影响

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