2016 Excel VBA Code for Locking a Cell after Data Entry

[Paul_Hossler]

Implemented via RightClick

Could probably use some more error checking

Option Explicit


Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    Dim rCell As Range
    Dim ans As VbMsgBoxResult


    For Each rCell In Target.Cells
        With rCell
            If Len(.Value) > 0 Then
            
                ans = MsgBox("Do you want to reset this cell?" & vbCrLf & vbCrLf & _
                    vbTab & .Value & "  (" & .Address(False, False) & ")", vbYesNo, "Cell Lock Notification")
                
                If ans = vbYes Then
                    If ActiveSheet.ProtectContents Then ActiveSheet.Unprotect Password:="123" '   unprotect first
                    Application.EnableEvents = False
                    .ClearContents
                    .Locked = False
                    Application.EnableEvents = True
                    ActiveSheet.Protect Password:="123"
                End If
            End If
        End With
    Next
        
    Cancel = True
    
End Sub


'I assume that the entire WS is Locked = False
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rCell As Range
    Dim ans As VbMsgBoxResult


    For Each rCell In Target
        With rCell
            If Len(.Value) > 0 Then
            
                ans = MsgBox("Is this entry correct?" & vbCrLf & vbCrLf & _
                    vbTab & .Value & "  (" & .Address(False, False) & ")" & vbCrLf & vbCrLf & _
                    "This cell cannot be edited after entering a value.", vbYesNo, "Cell Lock Notification")
                
                If ans = vbYes Then
                    If Me.ProtectContents Then Me.Unprotect Password:="123" '   unprotect first
                    .Locked = True
                    Me.Protect Password:="123" '   not Activeshet.
                
                Else
                    .ClearContents
                    ActiveCell.Offset(-1, 0).Select '   reselect data entry cell
                End If
            End If
        End With
    Next rCell
End Sub