VBA定时器无法按20ms间隔更新跨工作表单元格值求助

问题背景 #

需要实现每20ms从Sheet2的单元格依次取值，更新到Sheet1的B2单元格，采用Windows API的Timer而非循环，但点击启动按钮后定时器未按预期间隔触发（或逻辑无正确执行）。

核心错误分析 #

现有代码的问题集中在TimerProc及变量作用域：

• i是TimerProc的局部变量，每次定时器触发时都会被重新初始化为0，导致逻辑永远停留在重复读取Sheet2的A1单元格，无法实现递增取值，看起来像定时器没工作
• 冗余的条件判断完全没必要，且SetValue变量未被使用
• 未利用RunFlag变量控制定时器启停，存在重复启动风险
• 未处理Excel界面响应，长时间运行可能导致假死

修复后的完整代码 #

Option Explicit
Public RunFlag As Boolean
Public Declare PtrSafe Function SetTimer Lib "user32" ( _
    ByVal HWnd As Long, _
    ByVal nIDEvent As Long, _
    ByVal uElapse As Long, _
    ByVal lpTimerFunc As LongPtr) As Long

Public Declare PtrSafe Function KillTimer Lib "user32" ( _
    ByVal HWnd As Long, _
    ByVal nIDEvent As Long) As Long

Public TimerID As Long
Public TimerMs As Long ' 直接用毫秒单位更清晰
Public i As Integer ' 全局变量保持计数状态

Sub StartTimer()
    ' 防止重复启动
    If RunFlag Then Exit Sub
    
    TimerMs = 20 ' 间隔20毫秒
    TimerID = SetTimer(0&, 0&, TimerMs, AddressOf TimerProc)
    RunFlag = True
    i = 1 ' 初始化计数起始值
End Sub

Sub EndTimer()
    If TimerID <> 0 Then
        KillTimer 0&, TimerID
        TimerID = 0
        RunFlag = False
        i = 1 ' 重置计数
    End If
End Sub

Sub TimerProc(ByVal HWnd As Long, ByVal uMsg As Long, _
        ByVal nIDEvent As Long, ByVal dwTimer As Long)
    ' 检查运行标志，防止无效触发
    If Not RunFlag Then Exit Sub
    
    ' 处理Sheet2的取值边界（可选：到最后一行后重置）
    If i > Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row Then
        i = 1
    End If
    
    ' 更新Sheet1的B2单元格
    Worksheets("Sheet1").Cells(2, 2).Value = Worksheets("Sheet2").Cells(i, 1).Value
    
    ' 递增计数
    i = i + 1
    
    ' 让Excel响应界面操作，避免假死
    DoEvents
End Sub

Sub btnInit()
    StartTimer
End Sub

关键修改说明 #

• 将计数变量i改为全局变量，确保每次定时器触发时能保留上一次的计数状态
• 用RunFlag控制定时器启停，避免重复启动导致的异常
• 简化TimerProc逻辑，直接处理单元格取值与计数递增，加入边界判断防止越界
• 在TimerProc中添加DoEvents，保证Excel界面不会长时间无响应
• 变量命名更清晰（如TimerMs直接表示毫秒），避免混淆

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