Excel

Always Paste Special

Ease of Use

Intermediate

Version tested with

2003 

Submitted by:

Oorang

Description:

Make a workbook that all paste actions are "paste-special values". 

Discussion:

There are some cases where you might want to keep your workbook free of formatting, but still have access to the "undo" option. This will show you how to create a workbook that will intercept attempts to paste and replace them with paste-special values, while retaining the ability to "undo". 

Code:

instructions for use 

			
 '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" 
    RestorePasteButtons 
    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 
    Const lFNFError_c As Long = 53 
    LockInterface 
    If Excel.ActiveWorkbook Is Excel.ThisWorkbook Then 
        Set oFSO = VBA.CreateObject(m_sFSO_c) 
        If m_oPasteFile Is Nothing Then 
CreateFile: 
            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: 
    Select Case VBA.Err.Number 
    Case lPasteError_c 
        If Not bRunOnce Then 
            bRunOnce = True 
            VBA.Err.Clear 
            If Excel.Application.Dialogs(xlDialogPasteSpecial).Show Then 
                Resume Next 
            Else 
                Resume Exit_Proc 
            End If 
        End If 
    Case lFNFError_c 
        Resume CreateFile 
    End Select 
    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 
    Dim oPasteBtns As Office.CommandBarControls 
    Dim oPasteBtn As Office.CommandBarButton 
    Dim oNewBtn As Office.CommandBarButton 
    Const lIDPaste_c As Long = 22 
    RestorePasteButtons 
    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

How to use:

  1. Add a standard module.
  2. Paste above code in.
  3. In "ThisWorkbook" module call ForcePasteSpecial in the Workbook_Activate event.
  4. In "ThisWorkbook" module call ReleasePasteControl in the Workbook_Deactivate event.
 

Test the code:

  1. Open demo file.
  2. Copy something in the yellow area.
  3. Paste it in the non-formatted area, observe formatting is not pasted.
  4. Go to another workbook and paste again. Observe paste occurs normally now.
 

Sample File:

PasteSpecial_Demo.zip 21.11KB 

Approved by mdmackillop


This entry has been viewed 396 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2020 VBA Express