Disable Cut, Copy, Paste Macro for One Column

Reproduced from PM...

Quote:

---

Originally Posted by fluteloop_19

Hi Ken,

Can you please tell me how to use the Disable Cut, Copy, Paste Macro for one column only (column A)? This is for a template for other users and I need them to be able to copy and paste into the worksheet into other columns, except column A.

I would really appreciate the help. I have been struggling to find the answer for days for this.

Thank you very much!
Shannon

'*** In a standard module ***

Code:

---

Option Explicit
 
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
'Activate/deactivate drag and drop ability
Application.CellDragAndDrop = Allow
'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 in this workbook!"
End Sub

---

'*** In the ThisWorkbook Module ***

Code:

---

Option Explicit
 
Private Sub Workbook_Activate()
Call ToggleCutCopyAndPaste(False)
End Sub
 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call ToggleCutCopyAndPaste(True)
End Sub
 
Private Sub Workbook_Deactivate()
Call ToggleCutCopyAndPaste(True)
End Sub
 
Private Sub Workbook_Open()
Call ToggleCutCopyAndPaste(False)
End Sub

---

---

(The code above comes from our KB)

Hi Shannon,

The code in the standard module that you reproduced above doesn't change, but the code in the ThisWorkbook module will. I've given you a couple of scenarios that could happen in the Worksheet_SelectionChange routine; the first is excepting the entire column A on Sheet 1, the second is excepting only a specific range on Sheet 2, the third is to leave all other sheets with cut/copy/paste still working.

'*** In the ThisWorkbook Module ***

Code:

---

Option Explicit

Private Sub Workbook_Activate()
'Force the current selection to be selected, triggering the appropriate
'state of the cut, copy & paste commands
    Selection.Select
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Re-enable the cut, copy & paste commands
    Call ToggleCutCopyAndPaste(True)
End Sub

Private Sub Workbook_Deactivate()
'Re-enable the cut, copy & paste commands
    Call ToggleCutCopyAndPaste(True)
End Sub

Private Sub Workbook_Open()
'Force the current selection to be selected, triggering the appropriate
'state of the cut, copy & paste commands
    Selection.Select
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
'Toggle the cut, copy & paste commands on selected ranges
Select Case Sh.Name
  Case Is = "Sheet1"
      'Disable cut, copy & paste for Sheet1, Column A
      If Not Intersect(Target, Target.Parent.Columns(1)) Is Nothing Then
          Call ToggleCutCopyAndPaste(False)
          Else
        Call ToggleCutCopyAndPaste(True)
      End If
  Case Is = "Sheet2"
      'Disable cut, copy & paste for Sheet2, Range G1:H5
      If Not Intersect(Target, Target.Parent.Range("G1:H5")) Is Nothing Then
        Call ToggleCutCopyAndPaste(False)
        Else
        Call ToggleCutCopyAndPaste(True)
      End If
      Case Else
        'Re-enable cut copy and paste commands as this is not a restricted sheet
        Call ToggleCutCopyAndPaste(True)
    End Select
End Sub

---

Hope this helps,

I have used the code above and tweaked it to work for my workbook. However how do you disable cut, copy & paste for multiple cells?

In the code mentioned above it mentions:

Code:

---

Case Is = "Sheet2"
        'Disable cut, copy & paste for Sheet2, Range G1:H5
        If Not Intersect(Target, Target.Parent.Range("G1:H5")) Is Nothing Then
  Call ToggleCutCopyAndPaste(False)
  Else
  Call ToggleCutCopyAndPaste(True)

---

But how do I disable Cell (A2,D21,C47, C62:F62,.....)


Please PLEASE help if you can.

Regards,

K
:doh:: pray2::banghead:

The original disable cut copy paste disable worked in office 2003---but--doesnt seem to work in office 2007 as i can use the copy and paste in the ribbon- and the clipboard internal to the workbook (ie copy then paste to a second page) --or when opening another workbook---copying pasting from the clipboard. is there a way to disable the clipboard entirely?

Hi,
I’ve been searching for a solution on disabling cut/paste/copy functions in selected cell ranges rather than the entire worksheet. I couldn't find a really suitable solution until I found the very useful bit of code included in this post. For this I am really grateful.

As you will see pasted below, I’ve made some very minor modifications to allow a single column to have all the functions and I blocked a certain cell range.

It works perfectly, except for one small thing. I can’t figure out if I did something wrong to cause it, or if something changed in Excel 2003 (I’m on Sp3) since this original post was made.

The cell range I’ve blocked from using cut/copy/paste successfully blocks cut/copy/paste from right clicks, cut and copy on the toolbar, but the paste button on the toolbar is still visible.

Can anyone please point me in the right direction?

Code:

---

*** In the ThisWorkbook Module ***
Option Explicit
 
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
 
    'Activate/deactivate drag and drop ability
    Application.CellDragAndDrop = Allow
 
    '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
Private Sub Workbook_Activate()
    'Force the current selection to be selected, triggering the appropriate
    'state of the cut, copy & paste commands
    Selection.Select
End Sub
 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    'Re-enable the cut, copy & paste commands
    Call ToggleCutCopyAndPaste(True)
End Sub
 
Private Sub Workbook_Deactivate()
    'Re-enable the cut, copy & paste commands
    Call ToggleCutCopyAndPaste(True)
End Sub
 
Private Sub Workbook_Open()
    'Force the current selection to be selected, triggering the appropriate
    'state of the cut, copy & paste commands
    Selection.Select
End Sub
 
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    'Toggle the cut, copy & paste commands on selected ranges
 
    Select Case Sh.Name
    Case Is = "Contracting Activity"
        'Disable cut, copy & paste for Contracting Activity, Range D20:AD325
        If Not Intersect(Target, Target.Parent.Range("D20:AD325")) Is Nothing Then
            Call ToggleCutCopyAndPaste(False)
        Else
            Call ToggleCutCopyAndPaste(True)
        End If
 
    Case Is = "Planned Activity"
        'Disable cut, copy & paste for Planned Activity, Range D20:AD325
        If Not Intersect(Target, Target.Parent.Range("D20:AD325")) Is Nothing Then
            Call ToggleCutCopyAndPaste(False)
        Else
            Call ToggleCutCopyAndPaste(True)
        End If
 
    Case Else
        'Re-enable cut copy and paste commands as this is not a restricted sheet
        Call ToggleCutCopyAndPaste(True)
    End Select
End Sub

---

Hi Everybody,
Beginer in macros and VBA, I'm very glad to find what I look for since many days....
My need is a little bit different : I would like to "Disable Cut, Copy, Paste" for all the sheets, except a specific range in 2 different sheets....
I've tried to modify the above codes, but it does not work.
Help Please.

Hi Ken,

I am a newbie at VBA.

I had a public seminar presentation to do for which I used the code you had uploaded Disable Cut, Copy, Paste.

However now that my presentation has been done, I need to enable the cut copy paste functions on my workbook. HOW DO I DO THAT? I deleted the macro and saved the file but it still does not work. PLEASE HELP:friends:

Hi Ken,

I am a newbie at VBA.

I had a public seminar presentation to do for which I used the code you had uploaded Disable Cut, Copy, Paste.

However now that my presentation has been done, I need to enable the cut copy paste functions on my workbook. HOW DO I DO THAT? I deleted the macro and saved the file but it still does not work. PLEASE HELP:friends:

I know this is an old thread, but seeing that it shows up on Google's page 1 when searching for vba code to disable cut, copy and paste for a specified range and this was the most complete code I've ran across to do the task, I felt it appropriate to update this with a better version.

Bugs found in Ken's version when running under XL03 and WinXP Sp3:
1. Will allow a paste into restricted cells if a restricted cell is already selected and you are copying from a different sheet.

Fix: Add code to check the currently selected cell when you change worksheets.

2. Visa Versa of the above, if a restricted cell is selected and you need to paste something in another sheet. Say from an external source, when you switch to the other sheet, it is still disabled until you change cells.

Fix: Same as above. Checking currently selected cell when you change worksheets.

3. Probably the most important. At least under my system configuration, with drag and drop being disabled on selection change, it will deselect whatever has been copied, thus completely defeating the purpose of being able to copy and paste within cells outside of the restricted range.

Fix: Moved Disabling drag and drop to encompass the entire workbook. This may or may not be an issue for some, but it is the best I could come up with for now to ensure the cut, copy and paste restrictions work as intended.

4. The original use of Selection.Select would not trigger the code to check if the selected range is within the restricted range.

Fix: Switch to calling a sub that will check the activecell against the restricted range.

Additional Code Change information:
The actual checking of all ranges has moved to a sub called ChkSelection and added a function called InRange to use to check if the selected cell is within the range that is restricted.

The following is a modified version of Ken's original Disable Cut,Copy,Paste code....

Place the follow code into ThisWorkbook

Code:

---


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

---

Place the following code into its own standard module:

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

---

Enjoy and again, sorry for resurrecting an old thread, but like I said, it is the best I've ran across and shows up on Google's page 1, so I thought I would update it with something that functions a bit better for anyone else who runs across this thread.

Peixe,

Thank you very much. I am definately saving this web page in my snippets library.

SamT

This might suffice as well; all the code in the workbook codemodule.

Code:

---

Private Sub Workbook_Activate()
ChkSelection ActiveSheet
Application.CellDragAndDrop = True
End Sub
 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
ToggleCutCopyAndPaste True
Application.CellDragAndDrop = True
End Sub
 
Private Sub Workbook_Deactivate()
ToggleCutCopyAndPaste True
Application.CellDragAndDrop = True
End Sub
 
Private Sub Workbook_Open()
ChkSelection ActiveSheet
Application.CellDragAndDrop = False
End Sub
 
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
ChkSelection Sh
End Sub
 
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
ChkSelection Sh
End Sub
 
Sub ChkSelection(ByVal Sh As Object)
Select Case Sh.Name
  Case "Sheet1"
      ToggleCutCopyAndPaste Intersect(Selection, sh.Columns(1)) Is Nothing
  Case "Sheet2"
      ToggleCutCopyAndPaste Not Intersect(Selection, sh.range("G1:G20")) Is Nothing
  Case Else
      ToggleCutCopyAndPaste True
End Select
End Sub
 
Sub ToggleCutCopyAndPaste(v_true As Boolean)
EnableMenuItem Array(19, 21, 22, 75), v_true
For j = 1 To 5
  If v_true Then Application.OnKey Choose(j,"^c", "^v", "^x", "+{DEL}", "^{INSERT}")
  If Not v_true Then Application.OnKey Choose(j,"^c", "^v", "^x", "+{DEL}", "^{INSERT}"), "CutCopyPasteDisabled"
Next
End Sub
 
Sub EnableMenuItem(ctlId, v_Enabled As Boolean)
On Error Resume Next
For Each cb In Application.CommandBars
  If cb.Name <> "Clipboard" Then
      For Each it In ctlId
        cb.FindControl(, it).Enabled = v_Enabled
      Next
  End If
Next
End Sub
 
Sub CutCopyPasteDisabled()
MsgBox "Sorry! Cutting, copying and pasting have been disabled for the specified range."
End Sub

---

Good job SNB. Looks cleaner for sure. I'm not sure if there would be some unforeseen side effects of moving the subs to ThisWorkbook or not.

Although, I did see a minor bug that both of us missed.

Code:

---

Private Sub Workbook_Activate()     
    ChkSelection ActiveSheet     
    Application.CellDragAndDrop = True 
End Sub

---

Should actually read....

Code:

---

Private Sub Workbook_Activate()     
    ChkSelection ActiveSheet     
    Application.CellDragAndDrop = False 
End Sub

---

With the intent of turning off drag on drop for this workbook, but when switching back and forth between other workbooks, it would turn on and off. As is you could still slip one through if you opened another workbook, then came back to this one.

I won't comment on that one. :)

Please, the macro works perfect, but I need to activate it in one sheet for 2 columns, like this:

Code:

---

Sub ChkSelection(ByVal Sh As Object)
    Select Case Sh.Name
  Case "CLIENTE PN"
      ToggleCutCopyAndPaste Intersect(Selection, Sh.Columns(15)) Is Nothing
  Case "CLIENTE PJ"
      ToggleCutCopyAndPaste Intersect(Selection, Sh.Columns(13)) Is Nothing
  Case "CONCESIONARIOS"
      ToggleCutCopyAndPaste Intersect(Selection, Sh.Columns(10)) Is Nothing
  Case "PROVEEDORES"
      ToggleCutCopyAndPaste Intersect(Selection, Sh.Columns(13)) Is Nothing
  Case "PROVEEDORES"
      ToggleCutCopyAndPaste Intersect(Selection, Sh.Columns(17)) Is Nothing
  Case "EMPLEADOS"
      ToggleCutCopyAndPaste Intersect(Selection, Sh.Columns(16)) Is Nothing
  Case Else
      ToggleCutCopyAndPaste True
    End Select
End Sub

---

In sheet "PROVEEDORES" only detects the 13th column, but not the 17th column, the rest of the code works, with one exception:

In Excel 2013 the macro

Code:

---

Sub CutCopyPasteDisabled()
    MsgBox ("Lo sentimos, la fecha no puede ser copiada de otra celda")
End Sub

---

Only runs on a standard module, not in the Thisworkbook module
Thanks

fyrigoyeno,

This might work

Code:

---

Case "PROVEEDORES"
If Not Intersect(Selection, Sh.Columns(13)) Is Nothing Then
  ToggleCutCopyAndPaste Intersect(Selection, Sh.Columns(13)) Is Nothing
  ElseIf Not Intersect(Selection, Sh.Columns(17)) Is Nothing Then
  ToggleCutCopyAndPaste Intersect(Selection, Sh.Columns(17)) Is Nothing
End If

---

SamT:

Thanks for the lightspeed response, your code works perfect :clap2:

And thanks to all the rest of you guys, a perfect solution for controling things in a sheet.

Fyrigoyeno (newbie)

I just notice that when the macro runs at least one time and then I attemp to close the file I am getting this error:

Error 1004
Error in method "Intersect" on object "Global"
(sorry I dont know how to insert a image from url)
This is the line with the error:

Code:

---

Case "PROVEEDORES"
If Not Intersect(Selection, Sh.Columns(13)) Is Nothing Then
  ToggleCutCopyAndPaste Intersect(Selection, Sh.Columns(13)) Is Nothing
  ElseIf Not Intersect(Selection, Sh.Columns(17)) Is Nothing Then
  ToggleCutCopyAndPaste Intersect(Selection, Sh.Columns(17)) Is Nothing
    End If

---

The error comes up each time the macro runs, for example, If I run the macro on Sheet1, the error is present in the line of that sheet. If I run the macro on several Sheets, the error comes in the last sheet used when closing the file
Help on this please, here is my entire code:

This workbook module:

Code:

---

Private Sub Workbook_Activate()
    ChkSelection ActiveSheet
    Application.CellDragAndDrop = False
End Sub
 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    ToggleCutCopyAndPaste True
    Application.CellDragAndDrop = True
End Sub
 
Private Sub Workbook_Deactivate()
    ToggleCutCopyAndPaste True
    Application.CellDragAndDrop = True
End Sub
 
Private Sub Workbook_Open()
    ChkSelection ActiveSheet
    Application.CellDragAndDrop = False
End Sub
 
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    ChkSelection Sh
End Sub
 
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    ChkSelection Sh
End Sub
 
Sub ChkSelection(ByVal Sh As Object)
    Select Case Sh.Name
  Case "CLIENTE PN"
      ToggleCutCopyAndPaste Intersect(Selection, Sh.Columns(15)) Is Nothing
  Case "CLIENTE PJ"
      ToggleCutCopyAndPaste Intersect(Selection, Sh.Columns(13)) Is Nothing
  Case "CONCESIONARIOS"
      ToggleCutCopyAndPaste Intersect(Selection, Sh.Columns(10)) Is Nothing
  Case "PROVEEDORES"
      If Not Intersect(Selection, Sh.Columns(13)) Is Nothing Then
        ToggleCutCopyAndPaste Intersect(Selection, Sh.Columns(13)) Is Nothing
        ElseIf Not Intersect(Selection, Sh.Columns(17)) Is Nothing Then
        ToggleCutCopyAndPaste Intersect(Selection, Sh.Columns(17)) Is Nothing
      End If
  Case "EMPLEADOS"
      If Not Intersect(Selection, Sh.Columns(12)) Is Nothing Then
        ToggleCutCopyAndPaste Intersect(Selection, Sh.Columns(12)) Is Nothing
        ElseIf Not Intersect(Selection, Sh.Columns(16)) Is Nothing Then
        ToggleCutCopyAndPaste Intersect(Selection, Sh.Columns(16)) Is Nothing
      End If
  Case Else
      ToggleCutCopyAndPaste True
    End Select
End Sub
 
Sub ToggleCutCopyAndPaste(v_true As Boolean)
    EnableMenuItem Array(19, 21, 22, 755), v_true
For k = 1 To 6
  If v_true Then Application.OnKey Choose(k, "^c", "^j", "^v", "^x", "+{DEL}", "^{INSERT}")
  If Not v_true Then Application.OnKey Choose(k, "^c", "^j", "^v", "^x", "+{DEL}", "^{INSERT}"), "CutCopyPasteDisabled"
    Next
End Sub
 
Sub EnableMenuItem(ctlId, v_Enabled As Boolean)
    On Error Resume Next
For Each cb In Application.CommandBars
  If cb.Name <> "Clipboard" Then
      For Each it In ctlId
        cb.FindControl(, it).Enabled = v_Enabled
      Next
  End If
    Next
End Sub
 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.Index = 2 Then    ' 2'st sheet in workbook
  If Target.Column = 15 Then  ' 15'rd and 4th colums are active
      Application.Run ("fecha_hoy") 'Change 'MyMacro to your Macro's name
  End If
End If
If Sh.Index = 3 Then    ' 3'st sheet in workbook
  'End S
  If Target.Column = 13 Then  ' 15'rd and 4th colums are active
      Application.Run ("fecha_hoy") 'Change 'MyMacro to your Macro's name
  End If
End If
If Sh.Index = 4 Then    ' 4'st sheet in workbook
  If Target.Column = 10 Then  ' 15'rd and 4th colums are active
      Application.Run ("fecha_hoy") 'Change 'MyMacro to your Macro's name
  End If
End If
If Sh.Index = 5 Then    ' 5'st sheet in workbook
  If Target.Column = 13 Then  ' 15'rd and 4th colums are active
      Application.Run ("fecha_hoy") 'Change 'MyMacro to your Macro's name
  End If
End If
If Sh.Index = 5 Then    ' 5'st sheet in workbook
  If Target.Column = 17 Then  ' 15'rd and 4th colums are active
      Application.Run ("fecha_hoy") 'Change 'MyMacro to your Macro's name
  End If
End If
If Sh.Index = 6 Then    ' 5'st sheet in workbook
  If Target.Column = 12 Then  ' 15'rd and 4th colums are active
      Application.Run ("fecha_hoy") 'Change 'MyMacro to your Macro's name
  End If
End If
If Sh.Index = 6 Then    ' 5'st sheet in workbook
  If Target.Column = 16 Then  ' 15'rd and 4th colums are active
      Application.Run ("fecha_hoy") 'Change 'MyMacro to your Macro's name
  End If
End If
End Sub

---

In a Standard module:

Code:

---

Sub CutCopyPasteDisabled()
    MsgBox "Lo sentimos, la fecha no puede ser copiada de otra celda"
End Sub

---

Maybe the error comes with the Sub Workbook_BeforeClose() ??

The last one:

When the macro runs on both sheets "PROVEEDORES" and "EMPLEADOS" the warning comes up for ALL the cells, not only for columns 13 and 17 for example.
Thanks in advance

My first read shows to change these subs

Code:

---

Private Sub Workbook_Activate()
    ActiveSheet.Range("A1").Select
    Application.CellDragAndDrop = False
End Sub

Private Sub Workbook_Open()
    ActiveSheet.Range("A1").Select
    Application.CellDragAndDrop = False
End Sub

---

It is Very, Very dangerous to use Sheet.Index. It is equally dangerous to use Sheets(OneIndexNumber). Only if you are looping thru all sheets in a workbook should you use Sheets(i).

Here is how I would do this sub.

Code:

---

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim ShtName As String
  ShtName = Sh.Name
Dim Col As Long
  Col = Target.Column
'For certain columns on certain sheets, change Macro name
    If ShtName = "Sheet2" And Col = 15 Then Application.Run ("fecha_hoy")
  If ShtName = "Sheet3" And (Col = 3 Or Col = 13) Then Application.Run ("fecha_hoy")

---

You really need to put "Option Explicit" at the top of all your code modules. You have many undeclared variables and this will help you find them.

On the VBA menu >> Tools >> Options >> Editor, I recommend checking everything except Drag And Drop. This will really help you find code mistakes.

SamT:
Ok, this is what I'm getting know:
All variables declared (option Explicit at the beggining)

Solved problem in other workbooks with your suggestion:

Code:

---

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim ShtName As String
    ShtName = Sh.Name
    Dim Col As Long
    Col = Target.Column
If ShtName = "CLIENTE PN" And Col = 15 Then Application.Run ("fecha_hoy")
If ShtName = "CLIENTE PJ" And Col = 13 Then Application.Run ("fecha_hoy")
If ShtName = "CONCESIONARIOS" And Col = 10 Then Application.Run ("fecha_hoy")
If ShtName = "PROVEEDORES" And (Col = 13 Or Col = 17) Then Application.Run ("fecha_hoy")
If ShtName = "EMPLEADOS" And (Col = 12 Or Col = 16) Then Application.Run ("fecha_hoy")
End Sub

---

Solved problem (all cells controled) in sheets "PROVEEDORES" and "EMPLEADOS" with:

Code:

---

Case "PROVEEDORES"
  If Not Intersect(Selection, Sh.Columns(13)) Is Nothing Then
      ToggleCutCopyAndPaste Intersect(Selection, Sh.Columns(13)) Is Nothing
      ElseIf Not Intersect(Selection, Sh.Columns(17)) Is Nothing Then
      ToggleCutCopyAndPaste Intersect(Selection, Sh.Columns(17)) Is Nothing
      Else: ToggleCutCopyAndPaste True
  End If
  Case "EMPLEADOS"
      If Not Intersect(Selection, Sh.Columns(12)) Is Nothing Then
        ToggleCutCopyAndPaste Intersect(Selection, Sh.Columns(12)) Is Nothing
        ElseIf Not Intersect(Selection, Sh.Columns(16)) Is Nothing Then
        ToggleCutCopyAndPaste Intersect(Selection, Sh.Columns(16)) Is Nothing
        Else: ToggleCutCopyAndPaste True
  End If

---

Getting error 1004 (error in method select of clase range) with this when closing the workbook:

Code:

---

Private Sub Workbook_Activate()
    ActiveSheet.Range("A6").Select
    Application.CellDragAndDrop = False
End Sub

---

Show me the Workbook's BeforeClose and BeforeSave Codes

I think you'd better stick to:


[vba]Sub ChkSelection(ByVal Sh As Object) [/vba]
[vba]

Select Case Sh.Name

Case "CLIENTE PN"
ToggleCutCopyAndPaste Intersect(Selection, Sh.Columns(15)) Is Nothing
Case "CLIENTE PJ"
ToggleCutCopyAndPaste Intersect(Selection, Sh.Columns(13)) Is Nothing
Case "CONCESIONARIOS"
ToggleCutCopyAndPaste Intersect(Selection, Sh.Columns(10)) Is Nothing
Case "PROVEEDORES"
ToggleCutCopyAndPaste Intersect(Selection, range(Sh.Columns(13),Sh.Columns(17)) Is Nothing
Case "EMPLEADOS"
ToggleCutCopyAndPaste Intersect(Selection, Sh.Columns(16)) Is Nothing
Case Else
ToggleCutCopyAndPaste True
End Select

End Sub

[/vba]

SamT:

I have only BeforeClose sub:

[VBA]Option Explicit
Private Sub Workbook_Activate()
ActiveSheet.Range("A6").Select
Application.CellDragAndDrop = False

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
ToggleCutCopyAndPaste False
Application.CellDragAndDrop = True
End Sub

Private Sub Workbook_Deactivate()
ToggleCutCopyAndPaste True
Application.CellDragAndDrop = True
End Sub

Private Sub Workbook_Open()
ActiveSheet.Range("A6").Select
Application.CellDragAndDrop = False
End Sub

Private Sub Workbook_SheetActivate(ByVal SH As Object)
ChkSelection SH
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal SH As Object, ByVal Target As Range)
ChkSelection SH
End Sub

... continue rest of Sub's...

[/VBA]
Snb:

Getting a red line (error compilation) in
[VBA]
Case "PROVEEDORES"
ToggleCutCopyAndPaste Intersect(Selection, range (Sh.Columns(13),Sh.Columns(17)) Is Nothing
[/VBA]

And previously tried, with no result (nothing happens, no CutCopyAndPaste control):

[VBA]ToggleCutCopyAndPaste Intersect(Selection, (Sh.Columns(13)),Sh.Columns(17)) Is Nothing[/VBA]

I hardly believe that, but:

[VBA]
ToggleCutCopyAndPaste Intersect(Selection, Range("O:O,Q:Q")) Is Nothing
[/VBA]

Snb:

Now it's working and is a more simple code

thank you

I wish to disable the cut, paste and copy functions in my workbook executed by the user. I have inserted the module shown in the original post dated 5/5/2008 in this thread. It works! Except for one circumstance. My program can import worksheets from two separate types of Excel files. The first type is a file that does not contain the ToggleCutCopyAndPaste module. The second type does contains the ToggleCutCopyAndPaste module. When my program opens the file type that does not have the "ToggleCut..." module, everything works properly. However, when my program opens the Excel file that does have the ToggleCutCopyAndPaste module, a problem arises. My copy and insert worksheet routine appears to work properly. That is, the file is inserted into the current workbook just as expected. But, when focus is back on the current workbook and I execute any of the copy, cut or paste commands, the file from which the worksheet was copied, is opened; execution of that file's "ThisWorkbook" code begins and eventually crashes. It appears that something is getting imported with the worksheet, but I don't know what.

Curiously, if I save the file and reopen it, it works properly. Even more curious is, immediately after the offending "insert routine" is executed, if I go to any other application (such as NotePad) and perform a Copy Command, Excel crashes.

Can anyone suggest a fix for this or offer any insight?

Thanks,
KenS