Cell displays what's held in the clipboard

T

TheJay

Active Member
Joined
Nov 12, 2014
Messages
364
Office Version
  1. 2019
Platform
  1. Windows
Hello everyone, I want to create a sheet that has a cell displaying what is being held in the clipboard and it updates whenever the clipboard holds different data. Can someone please tell me if this is possible and if so, how it can be done? The reason for this is because there are multiple cells that the user can copy from and it's useful to see at a glance what is currently held.

Thanks.
 
Sort by date Sort by votes
Plus I don't want it to be in the tab/enter routine when going between unlocked cells.
 
Upvote 0

Excel Facts

Format cells as date
Select range and press Ctrl+Shift+3 to format cells as date. (Shift 3 is the # sign which sort of looks like a small calendar).
TheJay said:
Thank you, that worked to remove the double quotes.

The reason to prevent the cell being selected is because cells on the worksheet are automatically copied to the clipboard when selected. I don't want anyone to get confused about the fact that the specified cell is for information only.
Click to expand...
Does that mean you simply don't want the info cell E16 to to be copied by the user by mistake?
 
Upvote 0
I really don't want any interaction with the cell to be possible.
 
Upvote 0
Ideally an unprotect and protect routine around the VBA you have provided, if it's possible.
 
Upvote 0
On thing you may want to do is to lock the info cell (E16) and protect the worksheet.

Then the code will temporarly unprotect the worksheet before it attempts to udate the info cell. Once the info cell is updated, the code will automatically protect back the worksheet. That way, no user will be able to interact with info cell.

Replace the last oCbarEvents_OnUpdate event code with the following new versio:
VBA Code: 
Private Sub oCbarEvents_OnUpdate()

    Static lPrevSN As Long
   
    Dim MyDataObject As Object
    Dim lCutCopy As Long
    Dim sClipText As String
   
    If GetClipboardSequenceNumber <> lPrevSN Then
        If Application.CutCopyMode <> False Then
            With Sheets(TARGET_SHEET)
                lCutCopy = Application.CutCopyMode
                If Not Intersect(ActiveWindow.RangeSelection, .Range(TARGET_RANGE)) Is Nothing Then
                    Set MyDataObject = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
                    MyDataObject.GetFromClipboard
                    sClipText = MyDataObject.GetText(1)
                    Mid(sClipText, Len(sClipText), 1) = vbNullChar
                    If InStr(sClipText, Chr(&HA)) Then
                        sClipText = Replace(sClipText, Chr(&H22), "")
                    End If
                    If .ProtectContents Then
                     .Unprotect 'Password:="Enter your password here" <<== add password here if the sheet is password protected.
                    .Range(TARGET_INFO_RANGE) = sClipText
                    .Protect
                   End If
                    Set oCbarEvents = Nothing
                    If lCutCopy = 1 Then
                        ActiveWindow.RangeSelection.Copy
                    Else
                        ActiveWindow.RangeSelection.Cut
                    End If
                    Set oCbarEvents = Application.CommandBars
                End If
            End With
        End If
    End If
    lPrevSN = GetClipboardSequenceNumber
   
End Sub

If the worksheet is password protected, edit the above code and add the password (where the comment line in green is)
 
Upvote 0
To confirm current code:

ThisWorkbook:
VBA Code: 
Option Explicit

Private WithEvents oCbarEvents As CommandBars

#If VBA7 Then
    Private Declare PtrSafe Function GetClipboardSequenceNumber Lib "user32" () As Long
#Else
    Private Declare Function GetClipboardSequenceNumber Lib "user32" () As Long
#End If

Private Const TARGET_SHEET As String = "Clipboard"
Private Const TARGET_RANGE As String = "C7:C11,C13,C16,C19,C22,E7,E10,E13,E16,G13,G16"
Private Const TARGET_INFO_RANGE As String = "C4"

Private Sub Workbook_Open()
    Set oCbarEvents = Application.CommandBars
Application.EnableEvents = False
    Dim Sh As Worksheet
    For Each Sh In Worksheets
        If Sh.Name = "Property Numbering" Then
            Sh.Protect UserInterFaceOnly:=True, AllowSorting:=True, AllowFiltering:=True
            Sh.Range("C14,C8").ClearContents
            Sh.Range("B2").Value = "'Property Reference Guide (Click Arrow to Start)"
            Sh.Range("C14,C8").Value = "'Choose"
        ElseIf Sh.Name = "VO Areas" Then
            Sh.Protect UserInterFaceOnly:=True, AllowSorting:=True, AllowFiltering:=True
            Sh.Range("C4").ClearContents
            Sh.Range("C4").Value = "'Choose"
        Else
            Sh.Protect UserInterFaceOnly:=True
        End If
    Next
Application.EnableEvents = True
End Sub

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

Private Sub oCbarEvents_OnUpdate()

    Static lPrevSN As Long
    Dim MyDataObject As Object
    Dim lCutCopy As Long
    Dim sClipText As String
    
    If GetClipboardSequenceNumber <> lPrevSN Then
        If Application.CutCopyMode <> False Then
            With Sheets(TARGET_SHEET)
                lCutCopy = Application.CutCopyMode
                If Not Intersect(ActiveWindow.RangeSelection, .Range(TARGET_RANGE)) Is Nothing Then
                    Set MyDataObject = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
                    MyDataObject.GetFromClipboard
                    sClipText = MyDataObject.GetText(1)
                    Mid(sClipText, Len(sClipText), 1) = vbNullChar
                    If InStr(sClipText, Chr(&HA)) Then
                        sClipText = Replace(sClipText, Chr(&H22), "")
                    End If
                   .Range(TARGET_INFO_RANGE) = sClipText
                    Set oCbarEvents = Nothing
                    If lCutCopy = 1 Then
                        ActiveWindow.RangeSelection.Copy
                    Else
                        ActiveWindow.RangeSelection.Cut
                    End If
                    Set oCbarEvents = Application.CommandBars
                End If
            End With
        End If
    End If
    lPrevSN = GetClipboardSequenceNumber
End Sub

Clipboard Worksheet:
VBA Code: 
Option Explicit

Private Sub Worksheet_Activate()
    With Worksheets("Clipboard")
    MsgBox "Software relies heavily on the Windows clipboard." & Chr(13) & Chr(13) & "If you need to duplicate information to multiple accounts/properties, use this tool." & Chr(13) & Chr(13) & "Type the information needed, press ""Enter"" and then any cell you click on will automatically be copied to the clipboard.", vbInformation + vbOKOnly, "Automatic Clipboard"
         .Range("C4").Select
    End With
    With ActiveWindow
        .DisplayFormulas = False
        .DisplayHeadings = False
        .DisplayGridlines = False
        .DisplayHorizontalScrollBar = False
        .DisplayVerticalScrollBar = False
    End With
    With Application
        .DisplayFullScreen = True
        .DisplayFormulaBar = False
        .DisplayStatusBar = False
        .CommandBars("Full Screen").Visible = True
        .CommandBars("Worksheet Menu Bar").Enabled = False
        .CommandBars("Standard").Visible = False
        .CommandBars("Formatting").Visible = False
    End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Range("C7:C11,C13,C16,C19,C22,E7,E10,E13,E16,G13,G16")) Is Nothing Then
        Target.Copy
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim tabArray As Variant
    Dim i As Long
    tabArray = Array("C7", "C8", "C9", "C10", "C11", "C16", "C19", "C22", "E7", "E10", "E13", "E16", "G13", "G16")
    Application.ScreenUpdating = False
    For i = LBound(tabArray) To UBound(tabArray)
        If tabArray(i) = Target.Address(0, 0) Then
            If i = UBound(tabArray) Then
                Me.Range(tabArray(LBound(tabArray))).Select
            Else
                Me.Range(tabArray(i + 1)).Select
            End If
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

Sub PasteasValue()
Selection.PasteSpecial Paste:=xlPasteValues
End Sub
 
Upvote 0
Jaafar Tribak said:
On thing you may want to do is to lock the info cell (E16) and protect the worksheet.

Then the code will temporarly unprotect the worksheet before it attempts to udate the info cell. Once the info cell is updated, the code will automatically protect back the worksheet. That way, no user will be able to interact with info cell.

Replace the last oCbarEvents_OnUpdate event code with the following new versio:
VBA Code: 
Private Sub oCbarEvents_OnUpdate()

    Static lPrevSN As Long
  
    Dim MyDataObject As Object
    Dim lCutCopy As Long
    Dim sClipText As String
  
    If GetClipboardSequenceNumber <> lPrevSN Then
        If Application.CutCopyMode <> False Then
            With Sheets(TARGET_SHEET)
                lCutCopy = Application.CutCopyMode
                If Not Intersect(ActiveWindow.RangeSelection, .Range(TARGET_RANGE)) Is Nothing Then
                    Set MyDataObject = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
                    MyDataObject.GetFromClipboard
                    sClipText = MyDataObject.GetText(1)
                    Mid(sClipText, Len(sClipText), 1) = vbNullChar
                    If InStr(sClipText, Chr(&HA)) Then
                        sClipText = Replace(sClipText, Chr(&H22), "")
                    End If
                    If .ProtectContents Then
                     .Unprotect 'Password:="Enter your password here" <<== add password here if the sheet is password protected.
                    .Range(TARGET_INFO_RANGE) = sClipText
                    .Protect
                   End If
                    Set oCbarEvents = Nothing
                    If lCutCopy = 1 Then
                        ActiveWindow.RangeSelection.Copy
                    Else
                        ActiveWindow.RangeSelection.Cut
                    End If
                    Set oCbarEvents = Application.CommandBars
                End If
            End With
        End If
    End If
    lPrevSN = GetClipboardSequenceNumber
  
End Sub

If the worksheet is password protected, edit the above code and add the password (where the comment line in green is)
Click to expand...
Thank you. That's very good!

ThisWorkbook updated:
VBA Code: 
Option Explicit

Private WithEvents oCbarEvents As CommandBars

#If VBA7 Then
    Private Declare PtrSafe Function GetClipboardSequenceNumber Lib "user32" () As Long
#Else
    Private Declare Function GetClipboardSequenceNumber Lib "user32" () As Long
#End If

Private Const TARGET_SHEET As String = "Clipboard"
Private Const TARGET_RANGE As String = "C7:C11,C13,C16,C19,C22,E7,E10,E13,E16,G13,G16"
Private Const TARGET_INFO_RANGE As String = "C4"

Private Sub Workbook_Open()
    Set oCbarEvents = Application.CommandBars
Application.EnableEvents = False
    Dim Sh As Worksheet
    For Each Sh In Worksheets
        If Sh.Name = "Property Numbering" Then
            Sh.Protect UserInterFaceOnly:=True, AllowSorting:=True, AllowFiltering:=True
            Sh.Range("C14,C8").ClearContents
            Sh.Range("B2").Value = "'Property Reference Guide (Click Arrow to Start)"
            Sh.Range("C14,C8").Value = "'Choose"
        ElseIf Sh.Name = "VO Areas" Then
            Sh.Protect UserInterFaceOnly:=True, AllowSorting:=True, AllowFiltering:=True
            Sh.Range("C4").ClearContents
            Sh.Range("C4").Value = "'Choose"
        Else
            Sh.Protect UserInterFaceOnly:=True
        End If
    Next
Application.EnableEvents = True
End Sub

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

Private Sub oCbarEvents_OnUpdate()

    Static lPrevSN As Long
   
    Dim MyDataObject As Object
    Dim lCutCopy As Long
    Dim sClipText As String
   
    If GetClipboardSequenceNumber <> lPrevSN Then
        If Application.CutCopyMode <> False Then
            With Sheets(TARGET_SHEET)
                lCutCopy = Application.CutCopyMode
                If Not Intersect(ActiveWindow.RangeSelection, .Range(TARGET_RANGE)) Is Nothing Then
                    Set MyDataObject = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
                    MyDataObject.GetFromClipboard
                    sClipText = MyDataObject.GetText(1)
                    Mid(sClipText, Len(sClipText), 1) = vbNullChar
                    If InStr(sClipText, Chr(&HA)) Then
                        sClipText = Replace(sClipText, Chr(&H22), "")
                    End If
                    If .ProtectContents Then
                     .Unprotect
                    .Range(TARGET_INFO_RANGE) = sClipText
                    .Protect
                   End If
                    Set oCbarEvents = Nothing
                    If lCutCopy = 1 Then
                        ActiveWindow.RangeSelection.Copy
                    Else
                        ActiveWindow.RangeSelection.Cut
                    End If
                    Set oCbarEvents = Application.CommandBars
                End If
            End With
        End If
    End If
    lPrevSN = GetClipboardSequenceNumber
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question
Auto-Update Problem
Replies
0
Views
260
Diulama1023
D
A
  • Question
Follow a Hyperlink that creates a new Outlook e-mail message by using a VBA Excel Macro.
Replies
8
Views
1K
Agente442
A
W
  • Question
Sheet that updates by referencing cells in workbooks located in separate folders on shared drive
Replies
0
Views
150
Woodpusher147
W
N
  • Solved
Vstack, Chooserows & Dollar
2
Replies
18
Views
376
Nathan Asius
N
C
  • Question
Porting an Excel application to Access
Replies
6
Views
242
chazrab
C

Forum statistics

Threads
1,215,038
Messages
6,122,798
Members
449,095
Latest member
m_smith_solihull

Share this page

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