VBA实战技巧20：选取不同工作表中不同单元格区域时禁止用户执行复制剪切粘贴操作

2021-03-12 16:47:34 浏览数 (1)

excelperfect

在《VBA实战技巧19：根据用户在工作表中的选择来隐藏/显示功能区中的剪贴板组》中，我们讲解了根据用户在工作表中的选择来决定隐藏或者显示功能区选项卡中的特定组的技术。在这里就要派上用场了。

现在，我们需要用户在不同的工作表中选择不同的区域时，禁止用户执行复制、剪切、粘贴操作。例如，当用户选择工作表Sheet1列A中的单元格时，不能执行复制、剪切、粘贴操作，同样在选择工作表Sheet2中B2:B15区域时和工作表Sheet3中的列B、列C中的单元格时，也不能执行复制、剪切、粘贴操作。如下图1所示。

图1：当用户选择的不同工作表中指定的单元格时，不能执行复制、剪切、粘贴操作

首先，我们新建一个工作簿并保存。

然后，使用自定义UI工具打开该工作簿，输入如下所示的XML代码：

代码语言：javascript复制
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui"onLoad="Initialize">
    <ribbon>
       <tabs>
           <tab idMso="TabHome">
              <group idMso="GroupClipboard" getVisible="HideClipboard"/>
           </tab>
       </tabs>
    </ribbon>
</customUI>

如下图2所示。

图2：在Custom UI Editor For Microsoft Office中编辑输入XML

重新打开工作簿，按Alt F11键打开VBA编辑器，插入一个标准模块，输入下面的代码：

代码语言：javascript复制
Public rxIRibbonUI As IRibbonUI
Public bln As Boolean
 
'Callback for customUI.onLoad
Sub Initialize(ribbon As IRibbonUI)
    Set rxIRibbonUI = ribbon
End Sub
 
'Callback for GroupClipboardgetVisible
Sub HideClipboard(control As IRibbonControl, ByRef returnedVal)
   returnedVal = bln
End Sub
 
Sub chkSelection(ByVal Sh As Object)
    Dim rng As Range
    Set rng =Range(Selection.Address)
    Select Case Sh.Name
    Case Is ="Sheet1" '可修改为你的工作表名
        '禁用列A的复制粘贴功能
        If blnRange(rng, Columns("A:A")) Then
           Call ToggleCutCopyPaste(False)
        Else
           Call ToggleCutCopyPaste(True)
        End If
    Case Is ="Sheet2"
        '禁用单元格区域B2:B15的复制粘贴功能
        If blnRange(rng, Range("B2:B15")) Then
           Call ToggleCutCopyPaste(False)
        Else
           Call ToggleCutCopyPaste(True)
        End If
    Case Is ="Sheet3"
        '禁用列B列C的复制粘贴功能
        If blnRange(rng, Columns("B:C")) Then
           Call ToggleCutCopyPaste(False)
        Else
           Call ToggleCutCopyPaste(True)
        End If
    Case Else
        CallToggleCutCopyPaste(True)
    End Select
End Sub
 
Public Function blnRange(rng1 As Range, rng2 As Range)
    Dim interSectRange As Range
    Set interSectRange = Application.Intersect(rng1, rng2)
    blnRange= Not interSectRange Is Nothing
    Set interSectRange = Nothing
End Function
 
Sub ToggleCutCopyPaste(blnAllow As Boolean)
   '启用/禁用剪切,复制,粘贴和选择性粘贴
    Call EnableMenuItem(21, blnAllow) '剪切
    Call EnableMenuItem(19, blnAllow) '复制
    Call EnableMenuItem(22, blnAllow) '粘贴
    Call EnableMenuItem(755, blnAllow) '选择性粘贴
   
    With Application
       Select Case blnAllow
        Case Is = False
           .OnKey "^c", "CutCopyPasteDisabled"
           .OnKey "^v", "CutCopyPasteDisabled"
           .OnKey "x", "CutCopyPasteDisabled"
           .OnKey " {DEL}", "CutCopyPasteDisabled"
           .OnKey "^{INSERT}", "CutCopyPasteDisabled"
        Case Is = True
           .OnKey "^c"
           .OnKey "^v"
           .OnKey "^x"
           .OnKey " {DEL}"
           .OnKey "^{INSERT}"
        End Select
    End With
End Sub
 
Sub EnableMenuItem(ctlId As Integer, Enabled As Boolean)
   '启用/禁用特定的菜单项
    Dim cBar As CommandBar
    Dim cBarCtrl As CommandBarControl
    For Each cBar In Application.CommandBars
        If cBar.Name <> "Clipboard" Then
           Set cBarCtrl = cBar.FindControl(ID:=ctlId, Recursive:=True)
           If Not cBarCtrl Is Nothing Then
               cBarCtrl.Enabled = Enabled
           End If
        EndIf
    Next cBar
End Sub
 
Sub CutCopyPasteDisabled()
   '告知用户剪切/复制/粘贴已被禁用
    MsgBox"抱歉!在该单元格区域已禁用剪切,复制和粘贴功能."
End Sub

双击工程资源管理器中的ThisWorkbook模块，在该模块代码窗口中输入下面的代码：

代码语言：javascript复制
Private Sub Workbook_Open()
   '设置当前选取的单元格的复制粘贴状态
    Call chkSelection(ActiveSheet)
   Application.CellDragAndDrop = False
   WhichSheet
End Sub
 
Private Sub Workbook_Activate()
    Call chkSelection(ActiveSheet)
   Application.CellDragAndDrop = False
End Sub
 
Private Sub Workbook_Deactivate()
   '恢复复制粘贴状态
    Call ToggleCutCopyPaste(True)
   Application.CellDragAndDrop = True
End Sub
 
Private Sub Workbook_SheetActivate(ByVal Sh AsObject)
    Call chkSelection(Sh)
   WhichSheet
   rxIRibbonUI.InvalidateControlMso "GroupClipboard"
End Sub
 
Private Sub Workbook_SheetSelectionChange(ByVal ShAs Object, ByVal Target As Range)
    Call chkSelection(Sh)
   WhichSheet
   rxIRibbonUI.InvalidateControlMso "GroupClipboard"
End Sub
 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
   '恢复复制粘贴状态
    Call ToggleCutCopyPaste(True)
   Application.CellDragAndDrop = True
End Sub
 
Sub WhichSheet()
    Dim rng As Range
    Set rng =Range(Selection.Address)
    Select Case ActiveSheet.Name
    Case Is ="Sheet1" '可修改为你的工作表名
        '禁用列A的复制粘贴功能
        If blnRange(rng, Columns("A:A")) Then
           bln = False
        Else
           bln = True
        EndIf
    Case Is ="Sheet2"
        '禁用单元格区域B2:B15的复制粘贴功能
        If blnRange(rng, Range("B2:B15")) Then
           bln = False
        Else
           bln = True
        EndIf
    Case Is ="Sheet3"
        '禁用列B列C的复制粘贴功能
        If blnRange(rng, Columns("B:C")) Then
           bln = False
         Else
           bln = True
        EndIf
    End Select
End Sub

保存并关闭工作簿，然后重新打开该工作簿，试试看！效果应该如上图1中所示。

欢迎在下面留言，完善本文内容，让更多的人学到更完美的知识。

xml vba

0 人点赞