Consulting

Results 1 to 4 of 4

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

  1. #1
    VBAX Newbie
    Joined
    Oct 2020
    Posts
    3
    Location

    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.

    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

  2. #2
    VBAX Newbie
    Joined
    Oct 2020
    Posts
    3
    Location
    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

  3. #3
    VBAX Newbie
    Joined
    Oct 2020
    Posts
    3
    Location
    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

  4. #4
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    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.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •