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

[RobGER]

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.



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



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.



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

[RobGER]

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



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

[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".






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

[snb]

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.