Previously Locked cell gets unlocked with Target.Row valus

user_2922926 0
Viewed 33

I am trying to write a code to Lock a cell with respect to target row. In example, If we select Priority column as Yes then Column Y1 should be locked. I am able to do that. The problem comes when I work on next row. If we select Priority column as Yes in the next row, then cell c3 gets locked but cell C2 gets unlocked, how to keep the cell C2 as locked

My code so far :

Private Sub Worksheet_Change(ByVal Target As Range)

If target.column = 1 then
  If sheet1.range("A" & Target.Row).value = "Yes" then
    
sheet1.range("C" & target.row).locked = true
  activesheet.protect password:="pass"
  else
    sheet1.range("C" & target.row).locked = false
  End if

If we work on Row 2 then cell C2 gets locked, but if we work on Row 3 then cell C3 gets locked but C2 gets unlocked. How can we keep C2 as locked

Thanksenter image description here

vba excel
1 Answers

A Worksheet Change: Locking Cells

  • If you're not OP, best unlock all cells before copying the code to the sheet module e.g. Sheet1.
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Const FirstCellAddress As String = "A2"
    Const LockCellColumn As String = "C"
    
    Dim irg As Range
    With Range(FirstCellAddress)
        Set irg = Intersect(.Resize(Me.Rows.Count - .Row + 1), Target)
    End With
    If irg Is Nothing Then Exit Sub
    
    Application.EnableEvents = False
    Me.Unprotect Password:="pass"
    
    Dim iCell As Range
    Dim DoIt As Boolean
    Dim LockIT As Boolean
    
    For Each iCell In irg.Cells
        
        Select Case CStr(iCell.Value)
        Case "Yes"
            DoIt = True: LockIT = True
        Case "No"
            DoIt = True: LockIT = False
        Case Else ' do nothing
            DoIt = False
        End Select
        
        If DoIt Then
            iCell.EntireRow.Columns(LockCellColumn).Locked = LockIT
        End If
    
    Next iCell

    Me.Protect Password:="pass"
    Application.EnableEvents = True

End Sub
user_98140690
Related