VBA Disbale Copy&Paste in target range (not complete sheet/workbook)

Hello everyone


I am quite new to VBA and this forum and hope somebody of You can help me.


I am preparing an Excel Sheet which is clustered in an input area, required editable variables (cells with data validations) and an output area (formulas). To protect my formulas and variables, I locked a great portion of the sheet via the intrinsic cell protection. However, I have cells with drop-down menus und editable variables which I can not lock. As far as I know, the only way to protect a cell with data validation ist to disable copy&paste fuction. I searched in lots of forums but could only find quite old code which seems to not work at all. The major problem is that I want to enable these functions only in a specific target area and not in the whole sheet/workbook.


I am thinking of a combination of these 3 code blocks to get this problem solved, however my skills are that minor, that I can't figure it out by myself.

Code:

---

Option Explicit
Public Function InRange(Range1 As Range, Range2 As Range) As Boolean
' Added function to check if Cell is In Range
' returns True if Range1 is within Range2'
Dim InterSectRange As Range
    Set InterSectRange = Application.Intersect(Range1, Range2)
    InRange = Not InterSectRange Is Nothing
    Set InterSectRange = Nothing
End Function
Sub ChkSelection(ByVal Sh As Object)
    'Added Primarily to have one place to set restrictions
    'It also fixes the issue where a cell you don't want to
    'copy/paste from/to is already selected, but you
    'came from a sheet that wasn't protected.
   
    Dim rng As Range
    Set rng = Range(Selection.Address)


    Select Case Sh.Name
    Case Is = "Sheet1"
        'Disable copy and paste for anything in column A
        If InRange(rng, Columns("A")) Then
            Call ToggleCutCopyAndPaste(False)
        Else
            Call ToggleCutCopyAndPaste(True)
        End If


    Case Is = "Sheet2"
        'Disable copy and paste for anything in range G1 to G20
        If InRange(rng, Range("G1:G20")) Then
            Call ToggleCutCopyAndPaste(False)
        Else
            Call ToggleCutCopyAndPaste(True)
        End If


    Case Else
        Call ToggleCutCopyAndPaste(True)
    End Select


End Sub
Sub ToggleCutCopyAndPaste(Allow As Boolean)
    'Activate/deactivate cut, copy, paste and pastespecial menu items
    Call EnableMenuItem(21, Allow) ' cut
    Call EnableMenuItem(19, Allow) ' copy
    Call EnableMenuItem(22, Allow) ' paste
    Call EnableMenuItem(755, Allow) ' pastespecial
   


    'Drag and Drop Disabled from Original code due to deselecting what has been
    'copied and not allowing paste.  Moved to when workbook opens.
    'Drag and drop will not be allowed for entire workbook.
   
    'Activate/deactivate cut, copy, paste and pastespecial shortcut keys
    With Application
        Select Case Allow
        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)
    'Activate/Deactivate specific menu item
    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
    Next
End Sub
 
Sub CutCopyPasteDisabled()
    'Inform user that the functions have been disabled
    MsgBox "Sorry! Cutting, copying and pasting have been disabled for the specified range."
End Sub


Option Explicit
Private Sub Workbook_Activate()
    'Force the current selection to be selected, triggering the appropriate
    'state of the cut, copy & paste commands
    Call ChkSelection(ActiveSheet)
    Application.CellDragAndDrop = True
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    'Re-enable the cut, copy & paste commands
    Call ToggleCutCopyAndPaste(True)
    Application.CellDragAndDrop = True
End Sub
Private Sub Workbook_Deactivate()
    'Re-enable the cut, copy & paste commands
    Call ToggleCutCopyAndPaste(True)
    Application.CellDragAndDrop = True
End Sub
Private Sub Workbook_Open()
    'Force the current selection to be selected, triggering the appropriate
    'state of the cut, copy & paste commands
    Call ChkSelection(ActiveSheet)
    Application.CellDragAndDrop = False
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    Call ChkSelection(Sh)
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    'Toggle the cut, copy & paste commands on selected ranges
    Call ChkSelection(Sh)
End Sub

---

AND

Code:

---

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.CutCopyMode = True
Application.OnKey "^c"
Application.OnKey "^v"
Application.OnKey "^{INSERT}"
Application.OnKey "^{DELETE}"
Application.CommandBars("Cell").Enabled = True
Application.CellDragAndDrop = True
Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",True)"
End Sub

---

AND this 3. code which undos changes to certain target ranges. It works fine but doesn't inhipit copy and past.

Code:

---

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range
    Dim b As Boolean


    On Error GoTo Terminate


    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With


    For Each c In Target.Cells
        If Not Intersect(c, Range("A1:S15")) Is Nothing And c.Value = "" Then
            b = True
            GoTo UndoChange
        End If
    Next c


UndoChange:
    If b Then Application.Undo


Terminate:
    If Err Then
        Debug.Print "Error", Err.Number, Err.Description
        Err.Clear
    End If


    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

---

Thank you very much in advance for your help.


Best regards
RobGER

In the meanwhile I solved the problem on my own. In case onyone is interested, please find the code below:

Code:

---

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
 
    Dim c As Range
    Dim UndoList As String
    Dim result As Boolean
    Dim row As Integer
    Dim col As Integer
    Set Target = ActiveCell
   
    On Error GoTo Terminate


    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With


    If ActiveSheet.CodeName = "Sheet1" Then
        row = 15
        col = 19
        ElseIf ActiveSheet.CodeName = "Sheet2" Then
            row = 15
            col = 17
       
        ElseIf ActiveSheet.CodeName = "Sheet3" Then
            row = 18
            col = 19
    End If
   
    UndoList = Application.CommandBars("Standard").Controls("&Undo").List(1)
   
    result = IIf((Target.Column >= 1 And (Target.Column <= col And Target.row >= 1 And Target.row <= row)), True, False)
           
    If result = True And Left(UndoList, 5) = "Paste" Then
        MsgBox "Please don't paste values in this area of the sheet."
        With Application
            .Undo
            .CutCopyMode = False
        End With
        Target.Select


        ElseIf result = False And Left(UndoList, 5) = "Paste" Then
            Application.Undo
            Target.Select
            Target.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Union(Target, Selection).Select
   
        ElseIf UndoList = "Auto Fill" Then
            MsgBox "Please don't use 'Auto Fill' in this workbook."
            With Application
                .Undo
                .CutCopyMode = False
            End With
            Union(Target, Selection).Select
           
        ElseIf UndoList = "Drag and Drop" Then
            MsgBox "Please don't use 'Drag & Drop' in this workbook."
            With Application
                .CellDragAndDrop = False
                .CutCopyMode = False
                .Undo
            End With
            Union(Target, Selection).Select
           
    End If
   
    For Each c In Target.Cells
        If result = True And c.Value = "" Then
          Application.Undo
        End If
    Next c
   
Terminate:
    If Err Then
        Debug.Print "Error", Err.Number, Err.Description
        Err.Clear
    End If


    With Application
        .EnableEvents = True
        .ScreenUpdating = True
        .CellDragAndDrop = True
    End With
End Sub

---

Cheers,
RobGER

I further updated the code to protect cells in the worksheet by clearance in a better manner. Some cells are protected by data validation, so far cannot be cleared by "backspace" but still when pressing "Delete".

Code:

---



Option Explicit


Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) 'Special Sub which is triggered whenever a cell value is changed
 
    Dim UndoList As String     
    Dim result As Boolean     
    Dim row As Integer         
    Dim col As Integer         
    Set Target = ActiveCell   
   
    On Error GoTo Terminate   


    With Application           
        .EnableEvents = False 
        .ScreenUpdating = False   
    End With


    If ActiveSheet.CodeName = "Sheet1" Then   
        row = 15
        col = 19
    ElseIf ActiveSheet.CodeName = "Sheet2" Then
        row = 16
        col = 17
    ElseIf ActiveSheet.CodeName = "Sheet3" Then
        row = 18
        col = 19
    End If
   
    UndoList = Application.CommandBars("Standard").Controls("&Undo").List(1)   
   
    result = IIf((Target.Column >= 1 And (Target.Column <= col And Target.row >= 1 And Target.row <= row)), True, False)   
           
    If result = True And Left(UndoList, 5) = "Paste" Then     
        MsgBox "Please don't paste values in this area of the worksheet." 
        With Application               
            .Undo                     
            .CutCopyMode = False       
        End With
        Target.Select             


        ElseIf result = False And Left(UndoList, 5) = "Paste" Then     
            Application.Undo             
            Target.Select                 
            Target.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 
            Union(Target, Selection).Select   
   
        ElseIf UndoList = "Auto Fill" Then   
            MsgBox "Please don't use 'Auto Fill' in this workbook."
            With Application         
                .Undo                 
                .CutCopyMode = False   
            End With
            Union(Target, Selection).Select   
           
        ElseIf UndoList = "Drag and Drop" Then   
            MsgBox "Please don't use 'Drag & Drop' in this workbook." 
            With Application     
                .CellDragAndDrop = False   
                .CutCopyMode = False       
                .Undo                     
            End With
            Union(Target, Selection).Select   
       
        ElseIf UndoList = "Clear" Then 
            MsgBox "Please don't 'Clear' cells filled with values in blue font in this area of the worksheet."   
            Application.Undo 
            Union(Target, Selection).Select   
           
    End If
   
Terminate:
    If Err Then     
        Debug.Print "Error", Err.Number, Err.Description 
        Err.Clear           
    End If


    With Application         
        .EnableEvents = True 
        .ScreenUpdating = True 
        .CellDragAndDrop = True
    End With
End Sub

---

Cheers,
RobGER

Why automating things if you want to disable its automation options ?
You'd better use paper & pencil instead.

If you want to guide user input, use Userforms.