用 VBA 阻止用户在 Excel 表中粘贴数据(续)
- 2026-03-20 11:45:26
用 VBA 阻止用户在 Excel 表中粘贴数据(续) 前几天有同事提了一个需求：有什么办法可以阻止在 Excel 自检记录表中复制粘贴数据？起因是发现有人用复制粘贴的方法重复使用之前的检测数据。 由于公司制造流水线的这些自检记录表是我用 VBA 设计的，所以首先想到的就是用 VBA 来解决这个问题。经过几番尝试，在 ThisWorkbook 模块原有代码的基础上加了几行搞定： 由于程序自动清除了剪贴板，自然就没有什么可以粘贴的了
。 如果你也想实现这样的效果，可以按下面的方法操作试试： 1、选择要保护的数据区域，设置单元格格式。 
2、确保勾选了“锁定”（Excel 新建的工作表默认都是勾选的） 
3、在任意一个工作表名上点击鼠标右键，查看代码，进入 VBE 中。 
4、在 ThisWorkbook 模块中添加如下代码： 
5、保存修改后会自动锁定工作表，受保护区域就无法修改数据。 这一步的目的是防止 Excel 的宏功能被禁用无法自动清除剪贴板，由于表被锁定，也就阻止了粘贴数据的操作，要想填写数据必须启用宏功能。 
6、启用宏后只要执行了保存动作就会锁定工作表，要继续编辑就需要解锁，所以这里加一个“解锁”按钮，将其与“解锁”宏绑定。这样点击“解锁”就可以编辑了，当然粘贴数据是无效的
。 
7、为了进一步防止程序运行被破坏，还需要对 VBA 设置密码保护。 进入 VBA 工程属性 
8、设置工程保护密码，务必勾选“查看时锁定工程”。 
9、再设置一个工作簿密码保护，这样就比较完美了。 
延伸阅读：图解开启 Excel 的宏功能 上面是昨天写的，发现有一点点 Bug
，如果用户点击上图的"保护工作表"手动设置了密码保护，那么程序运行就会报错，所以呢下面我改了一下程序： 
ThisWorkbook 中的代码： 添加一个模块 
模块的代码：
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)' 自动清除剪贴板Application.CutCopyMode = FalseEnd Sub
。已关注
关注
重播 分享 赞
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)' 自动清除剪贴板Application.CutCopyMode = FalseEnd Sub'打开工作薄时执行，取消密码保护。Private Sub Workbook_Open()Call 解锁End Sub'保存工作薄时执行，添加密码保护。Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)Call 加锁End SubSub 解锁()ThisWorkbook.Sheets("正极").Unprotect Password:="abc123"End SubSub 加锁()ThisWorkbook.Sheets("正极").Protect Password:="abc123"End Sub
。，如果用户点击上图的"保护工作表"手动设置了密码保护，那么程序运行就会报错，所以呢下面我改了一下程序：Option ExplicitPrivate Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)' 自动清除剪贴板Application.CutCopyMode = FalseEnd Sub'打开工作薄时执行，取消密码保护。Private Sub Workbook_Open()Call 全解锁End Sub'保存工作薄时执行，添加密码保护。Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)Call 全加锁End Sub'保存工作薄后执行，取消密码保护Private Sub Workbook_AfterSave(ByVal Success As Boolean)Call 全解锁End Sub
Option Explicit' 定义密码常量Public Const PW As String = "这里替换为密码"Sub 全加锁()On Error Resume Next '忽略错误Dim ws As Worksheet' 遍历工作簿中的所有工作表For Each ws In ThisWorkbook.Worksheets'取工作表密码保护，防止用户设置了密码保护。ws.Protect AllowFiltering:=True: ws.Unprotect' 重新保护工作表ws.Protect Password:=PWNext wsOn Error GoTo 0End SubSub 全解锁()On Error Resume Next '忽略错误Dim ws As WorksheetFor Each ws In ThisWorkbook.Worksheetsws.Protect AllowFiltering:=True: ws.UnprotectNext wsOn Error GoTo 0End Sub
本文来自网友投稿或网络内容，如有侵犯您的权益请联系我们删除，联系邮箱：wyl860211@qq.com 。
