如何用VBA完全禁用Excel粘贴功能？解决现有代码首次粘贴仍生效问题

你的原脚本依赖Workbook_SheetChange事件，这个事件是粘贴操作完成后才触发，所以首次粘贴会先完成再执行撤销逻辑，导致首次粘贴无法被拦截。要彻底禁用粘贴，需要从多个操作入口同时限制：

1. 禁用粘贴快捷键 #

在ThisWorkbook模块的Workbook_Open事件中添加代码，拦截Ctrl+V、Shift+Insert等常用粘贴快捷键：

Private Sub Workbook_Open()
    ' 禁用Ctrl+V
    Application.OnKey "^v", ""
    ' 禁用Shift+Insert
    Application.OnKey "+{INSERT}", ""
    ' 禁用Ctrl+Shift+V（选择性粘贴）
    Application.OnKey "^+v", ""
End Sub

2. 移除右键菜单粘贴选项 #

继续在Workbook_Open中补充代码，删除右键菜单里的粘贴相关命令：

Private Sub Workbook_Open()
    ' 禁用粘贴快捷键
    Application.OnKey "^v", ""
    Application.OnKey "+{INSERT}", ""
    Application.OnKey "^+v", ""

    ' 移除右键菜单的粘贴选项
    On Error Resume Next
    CommandBars("Cell").Controls("Paste").Delete
    CommandBars("Cell").Controls("Paste Special...").Delete
    On Error GoTo 0
End Sub

3. 禁用Ribbon工具栏粘贴按钮 #

添加工作簿激活/失活事件，控制工具栏粘贴按钮的可用性：

Private Sub Workbook_Activate()
    ' 禁用工具栏粘贴按钮
    CommandBars("Standard").Controls("Paste").Enabled = False
    CommandBars("Standard").Controls("Paste Special").Enabled = False
End Sub

Private Sub Workbook_Deactivate()
    ' 切换到其他工作簿时恢复按钮（可选）
    CommandBars("Standard").Controls("Paste").Enabled = True
    CommandBars("Standard").Controls("Paste Special").Enabled = True
End Sub

4. 修复SheetChange兜底逻辑 #

原脚本的UndoString获取方式存在兼容性问题，修改后作为最后一道拦截：

Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)
    Dim UndoString As String
    
    ' 管理员模式跳过拦截
    If Range("swAdminMode").Value = "True" Then GoTo HandleExit
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    On Error Resume Next
    UndoString = Application.CommandBars("Standard").Controls("&Undo").Caption
    On Error GoTo 0
    
    ' 兼容中英文版本，判断是否为粘贴操作
    If InStr(1, UndoString, "Paste", vbTextCompare) > 0 Or InStr(1, UndoString, "粘贴", vbTextCompare) > 0 Then
        Application.Undo
        MsgBox "禁止粘贴，请手动填写内容！", vbExclamation
    End If

HandleExit:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

收尾恢复（可选） #

添加工作簿关闭事件，恢复快捷键和菜单，避免影响其他工作簿：

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    ' 恢复粘贴快捷键
    Application.OnKey "^v"
    Application.OnKey "+{INSERT}"
    Application.OnKey "^+v"
    
    ' 重置右键菜单
    On Error Resume Next
    CommandBars("Cell").Reset
    On Error GoTo 0
End Sub

所有代码均需放在Excel的ThisWorkbook模块中。

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