RobGER
10-13-2020, 02:52 AM
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
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