Allowing paste in a protected Excel workbook

Question

I have a workbook that some very non-technical people will be entering data into. In the past, I've had them type over formulas and otherwise screw up the data, so I've locked everything except where they're supposed to enter data, then I've password protected the workbook and worksheet. Unfortunately, Microsoft, in their infinite wisdom, decided that paste was a function that should be disabled in a protected worksheet/workbook (at least in Excel 2010).

Now, I've discovered that someone's been keeping data in their own workbook and needs to transfer it to mine, since mine is the official one. I borrowed this code from the internet, and have tweaked it a bit to more accurately apply to my particular situation. The code works just fine, however, it's quite rather slow, and I believe that it's the two loops that are killing performance.

I know there are a lot of other things that can be tweaked (Hungarian notation FTL), but I'm not concerned about those at the moment, I need to make this work faster and get it to the end user so she can copy/paste about 200 rows of data (in 3 groups of columns, due to the structure of the data) ASAP. I'll clean up the other little things with the help of RubberDuck once I've got it out the door. (Yes, I understand that's the wrong way about it, but time is of the essence.)

Here's the code:

Private Sub UnProtectPasteToSheet()

  On Error GoTo ErrHandler
  Dim bProtected As Boolean
  Dim oSheet  As Worksheet
  Dim oTempSheet As Worksheet
  Dim sPasteLocation As String
  Dim oCell As Range
  Dim oCollAddress As New Collection
  Dim oCollValue As New Collection
  Dim iCount  As Integer

  ' check protection status
  If Not ThisWorkbook.ActiveSheet.ProtectContents Then
    Selection.PasteSpecial Paste:=xlAll
  Else
    Set oSheet = ThisWorkbook.ActiveSheet
    'first unprotect the workbook so we can add the worksheet
    Dim ProtectStructure As Boolean
    Dim ProtectWindows As Boolean
    ToggleWorkbookProtection TheBook:=ThisWorkbook, Structure:=ProtectStructure, Window:=ProtectWindows, ProtectTheBook:=False

    ' save paste location
    sPasteLocation = Selection.Address
    ' unprotecting clears Clipboard in Excel!! strange but true..
    ' So paste it to a new sheet before unprotecting
    Set oTempSheet = ThisWorkbook.Worksheets.Add
    ' oSheet.Visible = xlSheetVeryHidden
    oTempSheet.Paste
    'then unprotect the sheet after storing off the pasted data
    oSheet.Unprotect Password:=MY_PWD
    bProtected = True

    ' make a note of all locked cells
    For Each oCell In oSheet.UsedRange
      If oCell.Locked Then
        oCollAddress.Add oCell.Address
        oCollValue.Add oCell.Value
      End If
    Next

    ' paste
    oTempSheet.UsedRange.Copy
    oSheet.Activate
    oSheet.Range(sPasteLocation).Select
    ' you need to paste only values since pasting format will lock all those cells
    ' since in Excel default status is "Locked"
    Selection.PasteSpecial xlValues

    ' remove temp sheet
    Application.DisplayAlerts = False
    oTempSheet.Delete
    Application.DisplayAlerts = True

    ' restore locked cells
    For iCount = 1 To oCollAddress.Count
      Range(oCollAddress.Item(iCount)) = oCollValue.Item(iCount)
    Next
    ' restore protection
    oSheet.Protect Password:=MY_PWD
    If ProtectStructure Or ProtectWindows Then
      ToggleWorkbookProtection TheBook:=ThisWorkbook, Structure:=ProtectStructure, Window:=ProtectWindows, ProtectTheBook:=True
    End If

  End If
  Exit Sub

ErrHandler:
  Debug.Print Err.Description
  If bProtected Then
    ThisWorkbook.ActiveSheet.Protect
  End If

End Sub

Private Sub ToggleWorkbookProtection(ByRef TheBook As Workbook, ByRef Structure As Boolean, ByRef Window As Boolean, ByVal ProtectTheBook As Boolean)

  If ProtectTheBook Then
    TheBook.Protect Structure:=Structure, Windows:=Window, Password:=MY_PWD
  Else
    Structure = TheBook.ProtectStructure
    Window = TheBook.ProtectWindows
    If Structure Or Window Then                   'only attempt to unprotect if it's protected.
      TheBook.Protect Structure:=False, Windows:=False, Password:=MY_PWD
    End If
  End If

End Sub

Answer 1

To catch the Paste event, the description in Excel VBA How to detect if something was pasted in a Worksheet provides good information. But to fully implement it, there are a couple of steps you need to watch for.

1. The link describes how to catch and recognize a Paste event, but then you need to perform the Undo as well and correctly recover the original formula
2. When you Replace the existing formula value with the newly pasted value, this triggers another Worksheet_Change event that you have to overcome.

To illustrate how to work around this, in Cell C3 enter the following formula:

="You pasted a "&TEXT(17.88,"0.000")

Then, in the Sheet module for your worksheet, try this example:

Option Explicit

Private workingCell As String

Private Sub Worksheet_Change(ByVal Target As Range)

    '--- restricts checking for a paste event to a
    '    specific range
    If (Target.Address = "$C$3") And (Len(workingCell) = 0) Then
        '--- set the workingCell to the target address
        '    when the "replace" occurs below, it triggers
        '    another change event for the same cell
        workingCell = Target.Address

        Dim undoList As String
        undoList = Application.CommandBars("Standard").Controls("&Undo").List(1)
        If Left(undoList, 5) = "Paste" Then
            '--- grab the pasted value, then undo the action to
            '    restore the formula
            Dim pastedValue As Variant
            pastedValue = Target.Value
            With Application
                .EnableEvents = False
                .Undo
                .EnableEvents = True
            End With

            '--- now replace the pasted value into the formula
            Const START_OF_VALUE = 23
            Dim pos1 As Long
            Dim oldValue As String
            pos1 = InStr(START_OF_VALUE, Target.Formula, ",", vbTextCompare)
            oldValue = Mid(Target.Formula, START_OF_VALUE, pos1 - START_OF_VALUE)
            Target.Formula = Replace(Target.Formula, oldValue, pastedValue, , , vbTextCompare)
            Debug.Print "Replaced '" & oldValue & "' with '" & pastedValue & "'"
            workingCell = ""
        End If
    End If
End Sub