Impedire l'utente di Excel 2010 di incollare la formattazione in cella

C'è un modo per bloccare una cella in modo che un utente può copiare / incollare un valore in esso, ma non copiare la formattazione? La chiusura del foglio di lavoro non impedisce all'utente di modificare la formattazione della cella mediante copia / incolla.

Non sto cercando la protezione contro gli utenti maligni, solo rendendo più facile per gli utenti ingenuo di copiare e incollare i valori.

Ecco la fonte di questa VBA. Non ho alcun credito .

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 

Quindi fare doppio clic su ThisWorkbook object e inserirlo

 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 

Quindi fare doppio clic sui fogli che si desidera applicare e inserire Option Explicit

Ora vai a Debug - Compile VBAProject
Questi fogli ora solo pasta-valore.