Before copy event?

eduzs

Well-known Member
Joined
Jul 6, 2014
Messages
704
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
I want to create a "before copy" event that will return an error message and abort the event if the current range selected is within some cells.
Thanks in advance.
 

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.
Alternatively, how can I prevent a cell or region from being copied? ( Can't lock or hide those cells)
 
Upvote 0
One way :

Code in the ThisWorkbook Module:

Code:
Option Explicit

Private WithEvents CmndBars As CommandBars

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function GetClipboardSequenceNumber Lib "user32" () As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Declare Function GetClipboardSequenceNumber Lib "user32" () As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

Private lCBrdSequenceNumber As Long
Private Const TAREGT_RANGE = "Sheet1!A1:A10" [B][COLOR=#008000]' <=== Change Target Range as required.[/COLOR][/B]

Private Sub Workbook_Open()
    lCBrdSequenceNumber = GetClipboardSequenceNumber
    Set CmndBars = Application.CommandBars
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    lCBrdSequenceNumber = GetClipboardSequenceNumber
    Set CmndBars = Application.CommandBars
End Sub

Private Sub CmndBars_OnUpdate()

    [B][COLOR=#008000]'Prevent copying any cell within range: "Sheet1!A1:A10" !![/COLOR][/B]
    With Application
        If Not Intersect(.ActiveWindow.RangeSelection, Range(TAREGT_RANGE)) Is Nothing Then
            If .CutCopyMode Then
                If lCBrdSequenceNumber <> GetClipboardSequenceNumber Then
                    .CutCopyMode = 0
                    MsgBox "You can't Cut or Copy any cell within the range :" & vbCr _
                    & TAREGT_RANGE, vbCritical
                End If
            End If
        End If
    End With
    lCBrdSequenceNumber = GetClipboardSequenceNumber

End Sub

Note that you will also need to disable the Cell Drag N Drop functionality when on the target range.
 
Last edited:
Upvote 0
Thanks!
How do I disable Cell Drag N Drop functionality?
 
Upvote 0
Yes, works fine! Thanks a lot.
So simple. I saw much complex codes elsewhere in google that I even wanted to try
It's possible to disable copy as image also?
Thanks
 
Last edited:
Upvote 0
Yes, works fine! Thanks a lot.
So simple. I saw much complex codes elsewhere in google that I even wanted to try
It's possible to disable copy as image also?
Thanks

What do you mean 'copy as image' ? Do you want to prevent the copying of images as well ? If so, where are the images ? and are the images within a specific range ?
 
Upvote 0
The "copy as image" option which is within the copy option in the menu. Copy a selected range as image.
 
Last edited:
Upvote 0
Ok. Try this .. Hopefully, this should prevent copying the range as Image or otherwise as well as prevent dragging and dropping the range :

Code in ThisWorkbook Module :

Code:
Option Explicit

Private WithEvents CmndBars As CommandBars

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function GetClipboardSequenceNumber Lib "user32" () As Long
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Declare Function GetClipboardSequenceNumber Lib "user32" () As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

Private lCBrdSequenceNumber As Long

Private Const TAREGT_RANGE = "Sheet1!A1:A10" [B][COLOR=#008000]' <=== Change Target Range as required.[/COLOR][/B]

Private Sub Workbook_Open()
    lCBrdSequenceNumber = GetClipboardSequenceNumber
    Set CmndBars = Application.CommandBars
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    lCBrdSequenceNumber = GetClipboardSequenceNumber
    Set CmndBars = Application.CommandBars
End Sub

Private Sub CmndBars_OnUpdate()

   [B][COLOR=#008000] 'Prevent copying and Dragging any cell within the range: "Sheet1!A1:A10" !![/COLOR][/B]
    With Application
        If ActiveSheet Is .Range(TAREGT_RANGE).Parent Then
            If Not Intersect(.ActiveWindow.RangeSelection, .Range(TAREGT_RANGE)) Is Nothing Then
                If .CellDragAndDrop Then OpenClipboard 0: .CellDragAndDrop = False: CloseClipboard
                If lCBrdSequenceNumber <> GetClipboardSequenceNumber Then
                    OpenClipboard 0
                    EmptyClipboard
                    CloseClipboard
                    MsgBox "You can't Cut or Copy any cell within the range :" & vbCr _
                    & TAREGT_RANGE, vbCritical
                End If
            Else
                If .CellDragAndDrop = False Then .CellDragAndDrop = True
            End If
        Else
            If .CellDragAndDrop = False Then .CellDragAndDrop = True
        End If
    End With
    lCBrdSequenceNumber = GetClipboardSequenceNumber

End Sub
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,557
Messages
6,114,288
Members
448,563
Latest member
MushtaqAli

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top