Excel实战技巧50： 避免因粘贴破坏数据有效性
学习Excel技术，关注微信公众号：
excelperfect
Excel数据有效性（在Excel 2013及以上版本中改称数据验证）是一项很方便的功能，帮助我们让用户在单元格中输入规定的数据。然而，将数据复制粘贴到设置了数据有效性的单元格时，会破坏掉数据有效性设置。
利用VBA代码，可以避免因粘贴数据而破坏单元格数据有效性设置。我原来的思路是，如果是有数据有效性设置的单元格，在用户粘贴数据前，我保存数据有效性设置，在用户粘贴后，使用工作表事件取消用户粘贴的数据，同时恢复原来的数据有效性设置。但一直没有着手编写代码，今天在jkp-ads.com中看到实现这样功能的代码，偷个懒，稍作整理和修改，辑录于此，供有需要的朋友参考。
要想避免粘贴操作带来的影响，首先要捕获所有可以采取的粘贴操作命令，有很多粘贴命令，包括：
1.Ctrl+V组合键
2.Ctrl+Insert组合键
3.Shift+Insert组合键
4.Enter键
5.功能区、菜单等位置的命令
下面是捕获粘贴操作并给出相应处理的代码。
在VBE中，插入一个名为clsCommandBarCatcher的类模块，输入代码：
'捕获命令栏中的单击以阻止粘贴
Public WithEvents oComBarCtl As Office.CommandBarButton
Private Sub Class_Terminate()
Set oComBarCtl = Nothing
End Sub
Private Sub oComBarCtl_Click( _
ByVal Ctrl As Office.CommandBarButton, _
cancelDefault As Boolean)
cancelDefault = True
Application.OnTime Now,"MyPasteValues"
End Sub
插入一个标准模块，输入代码：
Option Private Module
'禁用复制粘贴
Dim mcCatchers As Collection
'确保将所有的复制操作重定向到自已的操作
'以避免覆盖掉样式和有效性验证
Sub CatchPaste()
StopCatchPaste
Set mcCatchers = New Collection
'粘贴按钮
AddCatch "Dummy", 22
'粘贴(带下拉)
EnableDisableControl 6002, False
'选择性粘贴按钮
AddCatch "Dummy", 755
'粘贴链接按钮
AddCatch "Dummy", 2787
'粘贴格式按钮
AddCatch "Dummy", 369
'插入剪切单元格按钮
AddCatch "Dummy", 3185
'插入复制单元格按钮
AddCatch "Dummy", 3187
'Ctrl+V
Application.OnKey "^v", "MyPasteValues"
'Ctrl+Insert
Application.OnKey "^{Insert}", "MyPasteValues"
'Shift+Insert
Application.OnKey "+{Insert}", "MyPasteValues"
'Enter
Application.OnKey "~", "MyPasteValues"
Application.OnKey "{Enter}", "MyPasteValues"
'修改单元格拖放模式
If Application.CellDragAndDrop Then
Application.CellDragAndDrop = False
End If
End Sub
'重置粘贴操作为缺省值
Sub StopCatchPaste()
Dim lCount As Long
On Error Resume Next
Set mcCatchers = Nothing
EnableDisableControl 6002, True
Application.OnKey "^v"
Application.OnKey "^{Insert}"
Application.OnKey "+{Insert}"
Application.OnKey "~"
Application.OnKey "{Enter}"
'Application.CellDragAndDrop = True
End Sub
'添加要监控的命令栏控件
Sub AddCatch(sCombarName As String, lID As Long)
Dim oCtl As CommandBarControl
Dim CCatcher As clsCommandBarCatcher
Dim oBar As CommandBar
Set oCtl = Nothing
On Error Resume Next
Set oBar =Application.CommandBars(sCombarName)
If oBar Is Nothing Then
Set oBar =Application.CommandBars.Add(sCombarName, , , True)
oBar.Controls.Add ID:=lID
oBar.Visible = True
End If
With oBar
Set oCtl =.FindControl(ID:=lID, recursive:=True)
If oCtl Is NothingThen
Set oCtl = .Controls.Add(ID:=lID)
End If
End With
'试图通过单元格快捷菜单分别插入复制/剪切的单元格
If oCtl Is Nothing And (lID = 3185 Or lID = 3187) Then
Set oCtl =Application.CommandBars("Cell"). _
FindControl(ID:=lID, recursive:=True)
End If
Set CCatcher = New clsCommandBarCatcher
Set CCatcher.oComBarCtl =oCtl
mcCatchers.Add CCatcher
Set CCatcher = Nothing
oBar.Delete
Set oBar = Nothing
End Sub
'开启/禁用所有命令栏中的指定控件
Private Sub EnableDisableControl(lID As Long, bEnable As Boolean)
Dim oBar As CommandBar
Dim oCtl As CommandBarControl
On Error Resume Next
For Each oBar In CommandBars
Set oCtl =oBar.FindControl(ID:=lID, recursive:=True)
If Not oCtl Is Nothing Then
oCtl.Enabled =bEnable
End If
Next
End Sub
'从clsCommandBarCatcher的控件事件处理
'和不同的OnKey宏中调用专门的粘贴值程序
Public Sub MyPasteValues()
If Application.CutCopyMode <> False Then
If MsgBox("正常的粘贴操作已被禁用.你将粘贴值(不能撤销),是否继续?" _
& vbNewLine& "提示: 要想可以撤销粘贴, 使用命令栏中的粘贴值按钮.", _
vbQuestion +vbOKCancel, "禁止粘贴演示") = vbOK Then
On Error ResumeNext
Selection.PasteSpecial Paste:=xlValues
IsCellValidationOK Selection
End If
ElseIf Application.MoveAfterReturn Then
On Error Resume Next
Select Case Application.MoveAfterReturnDirection
Case xlUp
ActiveCell.Offset(-1).Select
Case xlDown
ActiveCell.Offset(1).Select
Case xlToRight
ActiveCell.Offset(, 1).Select
Case xlToLeft
ActiveCell.Offset(, -1).Select
End Select
End If
End Sub
'检查要粘贴到的单元格有无违反数据验证规则
'如果违反任意单元格验证则返回False
Public Function IsCellValidationOK(oRange As Object) As Boolean
Dim oCell As Range
If TypeName(oRange)<> "Range" Then Exit Function
IsCellValidationOK = True
For Each oCell In oRange
If NotoCell.Validation Is Nothing Then
If oCell.HasFormula Then
Else
If oCell.Validation.Value = False Then
IsCellValidationOK = False
Exit For
End If
End If
End If
Next
If IsCellValidationOK =False Then
MsgBox "警告!!!" & vbNewLine &vbNewLine & _
"粘贴操作导致不合规条目出现在1个或多个包含有效性验证规则的单元格中." _
& vbNewLine& vbNewLine & _
"请检查刚才粘贴值的所有单元格并改正错误!", _
vbOKOnly +vbExclamation, "禁止粘贴演示"
oRange.Select
End If
End Function
Public Sub MyPasteValues2007(control As IRibbonControl, ByRefcancelDefault)
MyPasteValues
End Sub
在工作簿ThisWorkbook代码模块，输入代码：
Private mdNextTimeCatchPaste As Double
Private Sub Workbook_Activate()
CatchPaste
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
StopCatchPaste
mdNextTimeCatchPaste =Now
Application.OnTimemdNextTimeCatchPaste, "'" & ThisWorkbook.Name &"'!CatchPaste"
Application.CellDragAndDrop = True
End Sub
Private Sub Workbook_Deactivate()
StopCatchPaste
On Error Resume Next
Application.OnTimemdNextTimeCatchPaste, "'" & ThisWorkbook.Name &"'!CatchPaste", , False
End Sub
Private Sub Workbook_Open()
CatchPaste
End Sub
在工作簿打开时，进行相应的设置。在工作簿关闭或者非当前工作簿时，恢复相应的设置。
关闭该工作簿，并使用CustomUI编辑器打开该工作簿，输入下面的XML代码：
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">
<commands>
<command idMso="Paste"onAction="MyPasteValues2007"/>
<command idMso="PasteSpecial"onAction="MyPasteValues2007"/>
<command idMso="PasteFormulas"onAction="MyPasteValues2007"/>
<command idMso="PasteFormatting"onAction="MyPasteValues2007"/>
<command idMso="PasteValues"onAction="MyPasteValues2007"/>
<command idMso="PasteNoBorders"onAction="MyPasteValues2007"/>
<command idMso="PasteTranspose"onAction="MyPasteValues2007"/>
<command idMso="PasteLink"onAction="MyPasteValues2007"/>
<command idMso="PasteSpecial"onAction="MyPasteValues2007"/>
<command idMso="PasteAsHyperlink"onAction="MyPasteValues2007"/>
<command idMso="PastePictureLink"onAction="MyPasteValues2007"/>
<command idMso="PasteAsPicture"onAction="MyPasteValues2007"/>
</commands>
</customUI>
保存并关闭CustomUI编辑器。再打开工作簿，试试效果，如下图1所示。
图1
标准模块代码的图片版如下：
clsCommandBarCatcher的类模块代码的图片版：
ThisWorkbook模块的代码图片版：
