Always paste special

yoko

Active Member
Joined
Sep 5, 2006
Messages
349
Hi,

I have a sheet which is protected but people are still able to change cell formats etc if they use the standard paste method. I want people to be able to paste data in but it forces paste special values to stop people pasting formats etc over already formatted and locked cells.

I know I could write a macro and run it using the shortcut keys ctrl-v but then the users lose the ability to undo if they make a mistake.

Is there a way to force paste special or allow users to run a macro but be able to do undo if they make a mistake?

Cheers,
 

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
Hello Yoko,
To accomplish what you are trying to do, you need to do three things:
  • 1.) Intercept attempts to paste in your workbook, and change the action to paste-special values.
    2.) Provide the ability to undo the action.
    3.) Intercept attempts to "Cut" as it cannot be pasted special.
As their is no "before-paste" event, we must instead find all possible ways for a user to paste and replace them. Fortunately this is not so difficult. There are only two shortcut keys to catch; and while their are many "paste buttons" to replace they all share the same ID, making our task much simpler.
Creating an Undo action can be accomplished by using the "OnUndo" property, but we have to program the undo action ourselves. I decided the simplest way to accomplish this would be to capture the worksheet state prior to the paste and store it. When the user wants to undo, you just clear the worksheet and replace the data. (There are more complex ways of doing this that will result in performance gains, but this way will work.) As a worksheet can easily carry more data then you can put in memory, I opted to write to a temp file. Here is the code:

Code:
'Written by Aaron Bush 08/06/2007
'Free for private Use, provided "As-Is" with no warranties express or implied.
'Please retain this notice.
Option Explicit
Option Private Module
Option Compare Binary
Private m_oPasteFile As Object
Private Const m_sFSO_c As String = "Scripting.FileSystemObject"
Private Const m_sPasteProcedure_c As String = "PasteSpecial"
Private Const m_sUbndoProcedure_c As String = "UndoPasteSpecial"
Private Const m_sCutWarningProcedure_c As String = "CutWarning"
Private m_oWS As Excel.Worksheet
'Microsoft Scripting Runtime Constants:
Private Const TristateTrue As Long = -1
Private Const ForReading As Long = 1
Private Const ForWriting As Long = 2
Private Const TemporaryFolder As Long = 2
'Error Handling Constants:
Private Const m_sTitle_c As String = "Error Number: "
Private Const m_lButtons_c As Long = vbExclamation + vbMsgBoxSetForeground + vbMsgBoxHelpButton
'Interface Control Constants:
Const m_sTag_c As String = "ForcePaste"
Public Sub ForcePasteSpecial()
    LockInterface
    Excel.Application.OnKey "^v", m_sPasteProcedure_c
    Excel.Application.OnKey "+{INSERT}", m_sPasteProcedure_c
    Excel.Application.OnKey "^x", m_sCutWarningProcedure_c
    ReplacePasteButtons
    CutButtonsEnable False
Exit_Proc:
    On Error Resume Next
    UnlockInterface
    Exit Sub
Err_Hnd:
    VBA.MsgBox VBA.Err.Description, m_lButtons_c, m_sTitle_c & CStr(VBA.Err.Number), VBA.Err.HelpFile, VBA.Err.HelpContext
    Resume Exit_Proc
End Sub
Public Sub ReleasePasteControl()
    On Error GoTo Err_Hnd
    LockInterface
    Excel.Application.OnKey "^v"
    Excel.Application.OnKey "+{INSERT}"
    Excel.Application.OnKey "^x"
    ReplacePasteButtons
    CutButtonsEnable True
Exit_Proc:
    On Error Resume Next
    m_oPasteFile.Delete True
    UnlockInterface
    Exit Sub
Err_Hnd:
    VBA.MsgBox VBA.Err.Description, m_lButtons_c, m_sTitle_c & CStr(VBA.Err.Number), VBA.Err.HelpFile, VBA.Err.HelpContext
    Resume Exit_Proc
End Sub
Private Sub PasteSpecial()
    On Error GoTo Err_Hnd
    Dim bRunOnce As Boolean
    Dim oFSO As Object
    Dim oTS As Object
    Dim oCll As Excel.Range
    Dim oDataRng As Excel.Range
    Dim lLstRow As Long
    Dim sTmpPth As String
    Const lPasteError_c As Long = 1004
    LockInterface
    If Excel.ActiveWorkbook Is Excel.ThisWorkbook Then
        Set oFSO = VBA.CreateObject(m_sFSO_c)
        If m_oPasteFile Is Nothing Then
            sTmpPth = oFSO.BuildPath(oFSO.GetSpecialFolder(TemporaryFolder), oFSO.GetTempName)
        Else
            sTmpPth = m_oPasteFile.ShortPath
        End If
        If oFSO.FileExists(sTmpPth) Then oFSO.DeleteFile sTmpPth, True
        oFSO.CreateTextFile sTmpPth, True, True
        Set m_oPasteFile = oFSO.GetFile(sTmpPth)
        Set oTS = m_oPasteFile.OpenAsTextStream(ForWriting, TristateTrue)
        Set oDataRng = Excel.ActiveSheet.UsedRange
        lLstRow = oDataRng.Row
        oTS.WriteLine oDataRng.Address
        For Each oCll In oDataRng.Cells
            If lLstRow <> oCll.Row Then
                lLstRow = oCll.Row
                oTS.Write vbNewLine
            End If
            oTS.Write oCll.Formula & vbTab
        Next oCll
        Set m_oWS = Excel.ActiveSheet
        Excel.Selection.PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, True, False
        Excel.Application.OnUndo "&Undo Paste", m_sUbndoProcedure_c
    Else
        Excel.ActiveSheet.Paste
    End If
Exit_Proc:
    On Error Resume Next
    oTS.Close
    UnlockInterface
    Exit Sub
Err_Hnd:
    If VBA.Err.Number = lPasteError_c Then
        If Not bRunOnce Then
            bRunOnce = True
            VBA.Err.Clear
            If Excel.Application.Dialogs(xlDialogPasteSpecial).Show Then Resume Next
        End If
    End If
    VBA.MsgBox VBA.Err.Description, m_lButtons_c, m_sTitle_c & CStr(VBA.Err.Number), VBA.Err.HelpFile, VBA.Err.HelpContext
    Resume Exit_Proc
    Resume
End Sub
Private Sub UndoPasteSpecial()
    On Error GoTo Err_Hnd
    Dim oTS As Object
    Dim lRow As Long
    Dim lCol As Long
    Dim vLine As Variant
    Dim sAddress As String
    Dim lColOffset As Long
    Const lLimit_c As Long = 256
    Const lStep_c As Long = 1
    Const lZero_c As Long = 0
    Const lOffset_c As Long = 1
    LockInterface
    If m_oPasteFile Is Nothing Then
        VBA.Err.Raise vbObjectError, m_sUbndoProcedure_c, "Cannot find stored paste data. Procedure cannot be reveresed."
    End If
    Set oTS = m_oPasteFile.OpenAsTextStream(ForReading, TristateTrue)
    If Not oTS.AtEndOfStream Then
        sAddress = oTS.ReadLine
        With m_oWS.Range(sAddress)
            lColOffset = .Column
            lRow = .Row
        End With
    End If
    m_oWS.UsedRange.ClearContents
    Do Until oTS.AtEndOfStream
        vLine = VBA.Split(oTS.ReadLine, vbTab, lLimit_c, vbBinaryCompare)
        For lCol = lZero_c To UBound(vLine)
            If VBA.IsNumeric(vLine(lCol)) Then
                m_oWS.Cells(lRow, lCol + lColOffset).Formula = CDbl(vLine(lCol))
            Else
                m_oWS.Cells(lRow, lCol + lColOffset).Formula = vLine(lCol)
            End If
        Next
        lRow = lRow + lStep_c
    Loop
Exit_Proc:
    On Error Resume Next
    oTS.Close
    UnlockInterface
    Exit Sub
Err_Hnd:
    VBA.MsgBox VBA.Err.Description, m_lButtons_c, m_sTitle_c & CStr(VBA.Err.Number), VBA.Err.HelpFile, VBA.Err.HelpContext
    Resume Exit_Proc
    Resume
End Sub
Private Sub ReplacePasteButtons()
    On Error GoTo Err_Hnd
    RestorePasteButtons
    Dim oPasteBtns As Office.CommandBarControls
    Dim oPasteBtn As Office.CommandBarButton
    Dim oNewBtn As Office.CommandBarButton
    Const lIDPaste_c As Long = 22
    Set oPasteBtns = Excel.Application.CommandBars.FindControls(ID:=lIDPaste_c)
    For Each oPasteBtn In oPasteBtns
        Set oNewBtn = oPasteBtn.Parent.Controls.Add(msoControlButton, Before:=oPasteBtn.Index, Temporary:=True)
        oNewBtn.FaceId = lIDPaste_c
        oNewBtn.Caption = oPasteBtn.Caption
        oNewBtn.TooltipText = oPasteBtn.TooltipText
        oNewBtn.Style = oPasteBtn.Style
        oNewBtn.BeginGroup = oPasteBtn.BeginGroup
        oNewBtn.Tag = m_sTag_c
        oNewBtn.OnAction = m_sPasteProcedure_c
        oPasteBtn.Visible = False
    Next
    Exit Sub
Err_Hnd:
    VBA.MsgBox VBA.Err.Description, m_lButtons_c, m_sTitle_c & CStr(VBA.Err.Number), VBA.Err.HelpFile, VBA.Err.HelpContext
End Sub
Private Sub RestorePasteButtons()
    On Error GoTo Err_Hnd
    Dim oBtns As Office.CommandBarControls
    Dim oBtn As Office.CommandBarButton
    Const lIDPaste_c As Long = 22
    Const m_sTag_c As String = "ForcePaste"
    Set oBtns = Excel.Application.CommandBars.FindControls(ID:=lIDPaste_c)
    For Each oBtn In oBtns
        oBtn.Visible = True
    Next
    Set oBtns = Excel.Application.CommandBars.FindControls(Tag:=m_sTag_c)
    If Not oBtns Is Nothing Then
        For Each oBtn In oBtns
            oBtn.Delete
        Next
    End If
    Exit Sub
Err_Hnd:
    VBA.MsgBox VBA.Err.Description, m_lButtons_c, m_sTitle_c & CStr(VBA.Err.Number), VBA.Err.HelpFile, VBA.Err.HelpContext
End Sub
Private Sub CutButtonsEnable(EnableButton As Boolean)
    On Error GoTo Err_Hnd
    Dim oCutBtns As Office.CommandBarControls
    Dim oCutBtn As Office.CommandBarButton
    Const lIDCut_c As Long = 21
    Set oCutBtns = Excel.Application.CommandBars.FindControls(ID:=lIDCut_c)
    For Each oCutBtn In oCutBtns
        oCutBtn.Enabled = EnableButton
    Next
    Exit Sub
Err_Hnd:
    VBA.MsgBox VBA.Err.Description, m_lButtons_c, m_sTitle_c & CStr(VBA.Err.Number), VBA.Err.HelpFile, VBA.Err.HelpContext
End Sub
Private Sub CutWarning()
On Error Resume Next
    VBA.MsgBox "The clipboard action ""Cut"" is not available for this workbook.", vbInformation + vbMsgBoxSetForeground, "Cut Disabled"
End Sub
Private Sub LockInterface()
    With Excel.Application
        .EnableEvents = False
        .ScreenUpdating = False
        .Cursor = xlWait
        .EnableCancelKey = xlErrorHandler
    End With
End Sub
Private Sub UnlockInterface()
    With Excel.Application
        .EnableEvents = True
        .ScreenUpdating = True
        .Cursor = xlDefault
        .EnableCancelKey = xlInterrupt
    End With
End Sub

In order to implement it, add a standard module and paste the code in. Then in "ThisWorkbook", paste this:
Code:
Option Explicit
Private Sub Workbook_Activate()
    ForcePasteSpecial
End Sub

Private Sub Workbook_Deactivate()
    ReleasePasteControl
End Sub
 
Upvote 0
Hmm this code now prevents me from doing normal paste in all worksheets even if the code is not there.

I've tried to paste the code in and run the ReleasePasteControl macro but it still wont let me do normal paste even if I remove all of your code...

Cheers
 
Upvote 0
Hello, I found this code on the web and was very pleased. It solves what seems should be a simple Event handler that visual basic does not have. I have used this code and it works great. Thanks!

However. I am geting an error when one copies a merged cell and attempts to past it to a non merged cell. Error number 1004. Is there a way to correct this? i don't care if it it just gives an error message and cancels the paste or if you just paste the first cell of the merge.
 
Upvote 0
Hmm this code now prevents me from doing normal paste in all worksheets even if the code is not there.

I've tried to paste the code in and run the ReleasePasteControl macro but it still wont let me do normal paste even if I remove all of your code...

Cheers


In order to permit other open sheets to function normally, add this code:

Private Sub Workbook_Activate()
Call ForcePasteSpecial
End Sub

Private Sub Workbook_Deactivate()
Call ReleasePasteControl
End Sub
 
Upvote 0
Hello, I found this code on the web and was very pleased. It solves what seems should be a simple Event handler that visual basic does not have. I have used this code and it works great. Thanks!

However. I am geting an error when one copies a merged cell and attempts to past it to a non merged cell. Error number 1004. Is there a way to correct this? i don't care if it it just gives an error message and cancels the paste or if you just paste the first cell of the merge.


FYI I am using Office 2007.

here is a fix until someone more adept at code than I am has a better solution. Modifaction to the error handleing code:

Err_Hnd:
Select Case VBA.Err.Number
Case lPasteError_c
If Not bRunOnce Then
bRunOnce = True
VBA.Err.Clear
MsgBox ("Can't paste to that cell")
'If Excel.Application.Dialogs(xlDialogPasteSpecial).Show Then
' Resume Next
'Else
Resume Exit_Proc
'End If
End If
 
Upvote 0
Hi yoko,
Sorry for the delayed reply. The full corrected version is here: http://www.vbaexpress.com/kb/getarticle.php?kb_id=957


Oorang, Thanks very much for this code! It is exactly what I need. However, I'm using Office / Excel 2007 and the paste button on the Ribbon is not deactivated. Any suggestions? Does the ReplacePasteButtons subroutine need to be updated?

While I have some programming experience, I'm a real newbie with VB.

Thanks!
 
Upvote 0
FYI I am using Office 2007.

DJHarris, I'm also using Office 2007, but when I use Oorang's code, the Paste button isn't disabled. The Ctrl-v is changed to Paste special, but you can still paste with the Paste button in the ribbon. Are you seeing the same thing or did you find a fix for that?
 
Upvote 0

Forum statistics

Threads
1,213,557
Messages
6,114,293
Members
448,564
Latest member
ED38

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