Which Range is currently being Cut or Copied ?

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,577
Office Version
  1. 2016
Platform
  1. Windows
Hi dear forum members,

I have a vba situation where I need to know the address of the range that is currently being copied (or cut) ie: when Application.CutCopyMode <> 0 .

I wonder if I am overlooking some easy solution or missing something obvious.

Regards.
 

Excel Facts

How to change case of text in Excel?
Use =UPPER() for upper case, =LOWER() for lower case, and =PROPER() for proper case. PROPER won't capitalize second c in Mccartney
It doesn't appear to be possible. Lots of other questions asking the same thing.

https://www.excelforum.com/excel-programming-vba-macros/1213141-get-marching-ants-range.html

https://stackoverflow.com/questions...rn-the-location-of-the-marching-ants-in-excel

However, if there is a solution, that might be handy someday.

Wow!! I never thought this question was asked so many times before .

Thanks for the links.

I'll take the Windows API route and see if that will offer a solution.
 
Upvote 0
This worked for me :

In a Standard Module:
Rich (BB code):
Option Explicit

#If  VBA7 Then
    Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
    Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#Else
    Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function CloseClipboard Lib "user32" () As Long
    Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
#End  If



Function GetCutCopyRange() As Range
    #If  VBA7 Then
        Dim hClipMem As LongPtr, lMemSize As LongPtr, lMemPtr As LongPtr
    #Else
        Dim hClipMem As Long, lMemSize As Long, lMemPtr As Long
    #End  If
   
    Const CF_LINK = &HC215&
    Dim bytBuffer() As Byte
    Dim oSheet As Worksheet
    Dim sClipLinkString As String, sRangeAddr As String, sSheetName As String, sWbookName As String
 
    On Error GoTo errHandler
    DoEvents
    If OpenClipboard(0) Then
        hClipMem = GetClipboardData(CF_LINK)
        If hClipMem Then lMemSize = GlobalSize(hClipMem)
        If lMemSize Then lMemPtr = GlobalLock(hClipMem)
        If lMemPtr Then
            ReDim bytBuffer(0 To CLng(lMemSize) - 1) As Byte
            Call CopyMemory(bytBuffer(0), ByVal lMemPtr, lMemSize)
            sClipLinkString = strConv(bytBuffer, vbUnicode)
            sClipLinkString = Right(sClipLinkString, Len(sClipLinkString) - InStrRev(sClipLinkString, "[") + 1)
            sClipLinkString = Replace(sClipLinkString, vbNullChar & vbNullChar, "")
            sRangeAddr = Split(sClipLinkString, vbNullChar)(1)
            sRangeAddr = Application.ConvertFormula(sRangeAddr, xlR1C1, xlA1)
            sSheetName = Split(Split(sClipLinkString, vbNullChar)(0), "]")(1)
            sWbookName = Split(Split(sClipLinkString, vbNullChar)(0), "]")(0) & "]"
            sWbookName = Replace(Replace(sWbookName, "[", ""), "]", "")
            Set oSheet = CallByName(Workbooks(sWbookName).Sheets, "Item", VbGet, sSheetName)
            Set GetCutCopyRange = CallByName(oSheet, "Range", VbGet, sRangeAddr)
            Call GlobalUnlock(hClipMem)
        End If
        Call CloseClipboard
    End If
   
errHandler:
    Call GlobalUnlock(hClipMem)
    Call CloseClipboard

End Function


Usage example:
Code:
Sub Test()

    Dim oCutCopyRange As Range
    Dim sCutOrCopied As String
   
    Set oCutCopyRange = GetCutCopyRange
   
    If Not oCutCopyRange Is Nothing Then
        sCutOrCopied = IIf(Application.CutCopyMode = xlCopy, "Copied", "Cut")
        sCutOrCopied = "Range being " & sCutOrCopied & ":" & vbNewLine
        MsgBox sCutOrCopied & oCutCopyRange.Address(, , , True)
    Else
        MsgBox "No range to cut or copy"
    End If

End Sub


One issue with the above function is that it gives erronous results whith non-contiguous ranges because Excel copies the whole range and doesn't adjust the copied range until the data is actually pasted.

For example:
If you copy the non-contiguous range A1:A2,E1:E2, excel copies A1:E2 to the clipboard and so the GetCutCopyRange function returns the wrong range.

Not sure how to work around this problem.
 
Last edited by a moderator:
Upvote 0
greetings, Jaafar
What about pasting a copy to a temporary worksheet?
Interrogate it to check for contiguous or not ranges. Delete worksheet when done.
regards, Fazza
 
Upvote 0
greetings, Jaafar
What about pasting a copy to a temporary worksheet?
Interrogate it to check for contiguous or not ranges. Delete worksheet when done.
regards, Fazza

Thanks for your recommendation.

I actually had thought about a similar workaround but in addition to that being a rustic fix, perhaps the main issue is the fact that when pasting a non-contiguous range, excel joins the parts of the copied range into a single block.- This makes it impossible to extrapolate the relative position of the rows and columns that is necessary to work out the exact address of the range being copied.

Regards.
 
Upvote 0
I can imagine this being flaky, but.. any chance of looping through the copied information & matching up the contents against the source cells?
I think that even for you very simple example A1:A2, E1:E2 it would not be robust/reliable.
 
Upvote 0
I can imagine this being flaky, but.. any chance of looping through the copied information & matching up the contents against the source cells?
I think that even for you very simple example A1:A2, E1:E2 it would not be robust/reliable.

Wouldn't that also require knowing the address of the source cells beforehand which is what we are actually trying to figure out in the first place ?

Excel provides no event for when the user performs a range Cut\Copy operation even the sheet change event doesn't fire when making a range copy... The Sheet Selection change won't help with this either.

If there was such an event, the problem with non-contigious ranges would be easy to solve.

I have an idea that might work and that is hooking the CommandBras event and checking in it the value of the clipboard sequence number which changes everytime a cut or copy operation is carried out.

I'll post the code when I finish testing it.

Regards.
 
Upvote 0
Ok- Finally, I seem to have managed to get through this by detecting the change in the clipboard serial number within the commandbars OnUpdate event and so far, the code seems very robust.

The GetCutCopyRange function now works with contigious as well as non-contigious ranges


Workbook example


1- Code in the ThisWorkbook Module:
Code:
Option Explicit

Private WithEvents CmndBrs 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 Sub Workbook_Activate()
    Call SetCommandBarsHook
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Call SetCommandBarsHook
End Sub

Private Sub SetCommandBarsHook()

    If CmndBrs Is Nothing Then
        With Application
            .CutCopyMode = 0
            .CommandBars.FindControl(ID:=128).Tag = _
            .ActiveWindow.RangeSelection.Address(False, False, , True) & "|" & GetClipboardSequenceNumber
            Set CmndBrs = .CommandBars
        End With
    End If

End Sub


Private Sub CmndBrs_OnUpdate()

    Dim sCutOrCopiedRangeAddr() As String
    
    With Application
        If TypeName(.Selection) = "Range" Then
            sCutOrCopiedRangeAddr = Split(.CommandBars.FindControl(ID:=128).Tag, "|")
            If sCutOrCopiedRangeAddr(1) <> GetClipboardSequenceNumber And .CutCopyMode <> 0 Then
                .CommandBars.FindControl(ID:=128).Tag = _
                .ActiveWindow.RangeSelection.Address(False, False, , True) & "|" & GetClipboardSequenceNumber
                sCutOrCopiedRangeAddr = Split(.CommandBars.FindControl(ID:=128).Tag, "|")
            End If
        End If
    End With

End Sub



Usage Example
2- Code in a Standard Module:
Code:
Option Explicit

Sub Test()

    Dim oCutCopyRange As Range
    Dim sCutOrCopyOperation As String

    Set oCutCopyRange = GetCutCopyRange

    If Not oCutCopyRange Is Nothing Then
        sCutOrCopyOperation = IIf(Application.CutCopyMode = xlCopy, "Copied", "Cut")
        sCutOrCopyOperation = "Range being *" & sCutOrCopyOperation & "*" & Chr(32) & ":" & vbNewLine & vbNewLine
        MsgBox sCutOrCopyOperation & oCutCopyRange.Address(False, False, , True)
    Else
        MsgBox "No range being cut or copied !", vbCritical
    End If

End Sub



Function GetCutCopyRange() As Range

    Dim sCutOrCopiedRangeAddr() As String
    
    If Application.CutCopyMode <> 0 Then
        sCutOrCopiedRangeAddr = Split(Application.CommandBars.FindControl(ID:=128).Tag, "|")
        Set GetCutCopyRange = Range(sCutOrCopiedRangeAddr(0))
    End If

End Function
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,207
Members
448,554
Latest member
Gleisner2

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