VBA实现toggle button点击后自动复位且不重复触发点击事件的方法

1 保留Toggle Button的修复方案 #

针对直接修改Value触发重复Click事件的问题，使用Application.EnableEvents属性临时关闭事件响应即可解决，同时实现操作完成后自动复位按钮状态。

1.1 点击事件修改 #

Private Sub MoveButton_Click()
    Select Case MoveButton.Value
        Case True
            GetData ActiveCell.Row, MoveButton
        Case False
            DropData ActiveCell.Row
            ' 临时关闭事件避免重复触发
            Application.EnableEvents = False
            MoveButton.Value = False
            Application.EnableEvents = True
    End Select
End Sub

Private Sub CopyButton_Click()
    Select Case CopyButton.Value
        Case True
            GetData ActiveCell.Row, CopyButton
        Case False
            DropData ActiveCell.Row
            Application.EnableEvents = False
            CopyButton.Value = False
            Application.EnableEvents = True
    End Select
End Sub

1.2 适配附加需求：传入按钮对象替代布尔值参数 #

修改GetData函数入参，直接接收按钮对象，自动判断操作类型：

Function GetData(iRowNumber As Integer, btn As Object)
    Dim cell As Range, bCopy As Boolean
    ' 自动识别操作类型
    bCopy = (btn.Name = "CopyButton")
    iRowNumberBackup = iRowNumber
    sRange = sSTARTROW & iRowNumber & ":" & sENDROW & iRowNumber
    Set rDataRange = Range(sRange)
    
    ' 空行拦截逻辑
    If rDataRange(1, 1) = 0 Then
        MsgBox "empty line"
        ' 空行直接复位按钮
        Application.EnableEvents = False
        btn.Value = False
        Application.EnableEvents = True
        Exit Function
    End If
    
    ' 数据存入剪切板数组
    ReDim sClipboard(rDataRange.Columns.Count)
    Dim i As Integer: i = 0
    For Each cell In rDataRange.Cells
        sClipboard(i) = cell.Value
        i = i + 1
    Next cell
    
    ' 移动操作删除原行数据
    If bCopy = False Then
        Range(sRange).ClearContents
    End If
    ' 更新按钮文案
    btn.Caption = sClipboard(0) & " - " & sClipboard(1) & " (" & sClipboard(2) & ")"
End Function

2 改用普通按钮的简化方案 #

如果不想处理Toggle Button的状态问题，替换为普通ActiveX命令按钮即可，逻辑更简洁，无状态冲突问题：

2.1 新增全局变量 #

' 原有变量保留，新增以下变量
Dim CurrentOperationBtn As Object

2.2 按钮点击事件 #

Private Sub MoveButton_Click()
    ' 剪切板为空则取数，不为空则放置数据
    If IsArrayEmpty(sClipboard) Then
        GetData ActiveCell.Row, MoveButton
    Else
        DropData ActiveCell.Row
    End If
End Sub

Private Sub CopyButton_Click()
    If IsArrayEmpty(sClipboard) Then
        GetData ActiveCell.Row, CopyButton
    Else
        DropData ActiveCell.Row
    End If
End Sub

2.3 新增辅助函数判断数组是否为空 #

Function IsArrayEmpty(arr As Variant) As Boolean
    On Error Resume Next
    IsArrayEmpty = (UBound(arr) < LBound(arr))
    If Err.Number <> 0 Then IsArrayEmpty = True
End Function

2.4 DropData函数适配修改 #

在DropData最后增加按钮文案复位逻辑即可，不需要处理按钮Value状态。

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