VBA形状单双击触发宏异常：单双击均仅更新J4单元格问题排查

核心错误原因 #

• 全局变量声明位置错误：Public LastClickObj As String, LastClickTime As Date 必须放在标准模块的最顶部声明区域，不能写在过程内部，否则每次调用过程变量都会被重置，无法记录上一次点击的信息
• 执行语句位置错误：你写的Set Wb = ThisWorkbook等赋值语句必须放在点击事件的Sub过程内部，直接放在模块声明区会导致运行异常
• 单击触发逻辑缺失：当前代码第一次点击时仅存储点击信息，没有触发单击判定逻辑，且0.25秒的间隔阈值过短，很多用户的双击操作间隔会超过这个值，导致无法被识别为双击
• 触发时机逻辑错误：当前代码在第二次点击间隔超阈值时才写J4，不符合常规的单击触发逻辑

修复后的完整代码 #

首先新建一个标准模块，将以下代码粘贴进去，再把所有Jan到Dec的形状的指定宏都设置为ShapeClick即可：

' 放在标准模块最顶部的声明区域
Public LastClickObj As String
Public LastClickTime As Double
Const DOUBLE_CLICK_GAP As Double = 0.3 ' 双击间隔阈值，单位秒，可根据使用习惯调整

Sub ShapeClick()
    Dim Wb As Workbook
    Dim WsCharts As Worksheet
    Dim btnMonthName As String
    
    Set Wb = ThisWorkbook
    Set WsCharts = Wb.Sheets("Trend Charts")
    btnMonthName = WsCharts.Shapes(Application.Caller).Name
    
    ' 判断是否为同形状的双击操作
    If LastClickObj = Application.Caller And (Timer - LastClickTime) < DOUBLE_CLICK_GAP Then
        ' 执行双击逻辑
        WsCharts.Range("M4").Value = btnMonthName
        ' 重置状态避免连续点击误判
        LastClickObj = ""
        Exit Sub
    End If
    
    ' 存储当前点击信息，等待判断是否为双击
    LastClickObj = Application.Caller
    LastClickTime = Timer
    
    ' 延迟阈值时间后校验是否为单击
    Application.OnTime Now + TimeSerial(0, 0, DOUBLE_CLICK_GAP), "CheckSingleClick"
End Sub

Sub CheckSingleClick()
    Dim WsCharts As Worksheet
    Set WsCharts = ThisWorkbook.Sheets("Trend Charts")
    
    ' 等待时间结束后没有第二次同对象点击，判定为单击
    If LastClickObj <> "" Then
        WsCharts.Range("J4").Value = WsCharts.Shapes(LastClickObj).Name
        LastClickObj = ""
    End If
End Sub

注意事项 #

• 如果觉得双击识别不灵敏，可以适当调大DOUBLE_CLICK_GAP的数值，0.3-0.5秒是比较通用的适配区间
• 全局变量不能放在工作表模块、类模块或者过程内部，必须放在独立的标准模块最顶部才能生效
• 所有Jan-Dec的形状都要绑定ShapeClick宏，不要出现漏绑的情况

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