Prevent Excel 2010 user from pasting formatting into cell

Is there a way to lock a cell so that a user can copy/paste a value into it, but not copy formatting to it? Locking the worksheet doesn't prevent the user from changing the formatting of the cell by copy/paste.

I'm not looking for protection against malicious users, just making it easier for naive users to copy and paste values.

Solution 1:

Here is the source of this VBA. I take no credit.

Alt+F11 Insert - module

'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

Then double click ThisWorkbook object and put in

Option Explicit
Private Sub Workbook_Activate()
    Debug.Print "Workbook_Activate"
    ForcePasteSpecial
End Sub

'Private Sub Workbook_BeforeClose(Cancel As Boolean)
'    Debug.Print "Workbook_BeforeClose"
'    ReleasePasteControl
'End Sub
'
Private Sub Workbook_Deactivate()
    Debug.Print "Workbook_Deactivate"
    ReleasePasteControl
End Sub

Then double click the sheets you want this to apply to and put in Option Explicit

Now go to Debug - Compile VBAProject
Those sheets now will only paste-value.

Prevent Excel 2010 user from pasting formatting into cell

Solution 1:

Related

Recent Posts