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