Automatic locking of cells based on a cell value

[Hippolyte]

Hello,

I would like to know if there is a way to lock a cell based on the content of another cell on the same line ? (this action will occur multiple times in the sheet)

So far I have this but it doesn't seem to work and looks quite heavy ...

I would be very grateful if somebody could help me out on this :

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(ActiveSheet.Cells(32, 9), Target) Is Not Nothing Then
If ActiveSheet.Cells(32, 9).Text = "k€" Then
ActiveSheet.Range(Cells(32, 10)).Locked = True
Else
ActiveSheet.Range(Cells(32, 10)).Locked = False
End If
If Intersect(ActiveSheet.Cells(33, 9), Target) Is Not Nothing Then
If ActiveSheet.Cells(32, 9).Text = "k€" Then
ActiveSheet.Range(Cells(33, 10)).Locked = True
Else
ActiveSheet.Range(Cells(33, 10)).Locked = False
End If
If Intersect(ActiveSheet.Cells(34, 9), Target) Is Not Nothing Then
If ActiveSheet.Cells(32, 9).Text = "k€" Then
ActiveSheet.Range(Cells(34, 10)).Locked = True
Else
ActiveSheet.Range(Cells(34, 10)).Locked = False
End If
If Intersect(ActiveSheet.Cells(35, 9), Target) Is Not Nothing Then
If ActiveSheet.Cells(35, 9).Text = "k€" Then
ActiveSheet.Range(Cells(35, 10)).Locked = True
Else
ActiveSheet.Range(Cells(35, 10)).Locked = False
End If
If Intersect(ActiveSheet.Cells(36, 9), Target) Is Not Nothing Then
If ActiveSheet.Cells(32, 9).Text = "k€" Then
ActiveSheet.Range(Cells(36, 10)).Locked = True
Else
ActiveSheet.Range(Cells(36, 10)).Locked = False
End If
If Intersect(ActiveSheet.Cells(37, 9), Target) Is Not Nothing Then
If ActiveSheet.Cells(37, 9).Text = "k€" Then
ActiveSheet.Range(Cells(37, 10)).Locked = True
Else
ActiveSheet.Range(Cells(37, 10)).Locked = False
End If
If Intersect(ActiveSheet.Cells(38, 9), Target) Is Not Nothing Then
If ActiveSheet.Cells(38, 9).Text = "k€" Then
ActiveSheet.Range(Cells(38, 10)).Locked = True
Else
ActiveSheet.Range(Cells(38, 10)).Locked = False
End If
If Intersect(ActiveSheet.Cells(39, 9), Target) Is Not Nothing Then
If ActiveSheet.Cells(39, 9).Text = "k€" Then
ActiveSheet.Range(Cells(39, 10)).Locked = True
Else
ActiveSheet.Range(Cells(39, 10)).Locked = False
End If
If Intersect(ActiveSheet.Cells(40, 9), Target) Is Not Nothing Then
If ActiveSheet.Cells(40, 9).Text = "k€" Then
ActiveSheet.Range(Cells(40, 10)).Locked = True
Else
ActiveSheet.Range(Cells(40, 10)).Locked = False
End If
If Intersect(ActiveSheet.Cells(41, 9), Target) Is Not Nothing Then
If ActiveSheet.Cells(41, 9).Text = "k€" Then
ActiveSheet.Range(Cells(41, 10)).Locked = True
Else
ActiveSheet.Range(Cells(41, 10)).Locked = False
End If
If Intersect(ActiveSheet.Cells(42, 9), Target) Is Not Nothing Then
If ActiveSheet.Cells(42, 9).Text = "k€" Then
ActiveSheet.Range(Cells(42, 10)).Locked = True
Else
ActiveSheet.Range(Cells(42, 10)).Locked = False
End If
If Intersect(ActiveSheet.Cells(43, 9), Target) Is Not Nothing Then
If ActiveSheet.Cells(43, 9).Text = "k€" Then
ActiveSheet.Range(Cells(43, 10)).Locked = True
Else
ActiveSheet.Range(Cells(43, 10)).Locked = False
End If
If Intersect(ActiveSheet.Cells(44, 9), Target) Is Not Nothing Then
If ActiveSheet.Cells(44, 9).Text = "k€" Then
ActiveSheet.Range(Cells(44, 10)).Locked = True
Else
ActiveSheet.Range(Cells(44, 10)).Locked = False
End If
If Intersect(ActiveSheet.Cells(45, 9), Target) Is Not Nothing Then
If ActiveSheet.Cells(45, 9).Text = "k€" Then
ActiveSheet.Range(Cells(45, 10)).Locked = True
Else
ActiveSheet.Range(Cells(45, 10)).Locked = False
End If
If Intersect(ActiveSheet.Cells(46, 9), Target) Is Not Nothing Then
If ActiveSheet.Cells(46, 9).Text = "k€" Then
ActiveSheet.Range(Cells(46, 10)).Locked = True
Else
ActiveSheet.Range(Cells(46, 10)).Locked = False
End If
If Intersect(ActiveSheet.Cells(47, 9), Target) Is Not Nothing Then
If ActiveSheet.Cells(47, 9).Text = "k€" Then
ActiveSheet.Range(Cells(47, 10)).Locked = True
Else
ActiveSheet.Range(Cells(47, 10)).Locked = False
End If
If Intersect(ActiveSheet.Cells(48, 9), Target) Is Not Nothing Then
If ActiveSheet.Cells(48, 9).Text = "k€" Then
ActiveSheet.Range(Cells(48, 10)).Locked = True
Else
ActiveSheet.Range(Cells(48, 10)).Locked = False
End If
If Intersect(ActiveSheet.Cells(49, 9), Target) Is Not Nothing Then
If ActiveSheet.Cells(49, 9).Text = "k€" Then
ActiveSheet.Range(Cells(49, 10)).Locked = True
Else
ActiveSheet.Range(Cells(49, 10)).Locked = False
End If
If Intersect(ActiveSheet.Cells(50, 9), Target) Is Not Nothing Then
If ActiveSheet.Cells(50, 9).Text = "k€" Then
ActiveSheet.Range(Cells(50, 10)).Locked = True
Else
ActiveSheet.Range(Cells(50, 10)).Locked = False
End If
If Intersect(ActiveSheet.Cells(51, 9), Target) Is Not Nothing Then
If ActiveSheet.Cells(51, 9).Text = "k€" Then
ActiveSheet.Range(Cells(51, 10)).Locked = True
Else
ActiveSheet.Range(Cells(51, 10)).Locked = False
End If
If Intersect(ActiveSheet.Cells(52, 9), Target) Is Not Nothing Then
If ActiveSheet.Cells(52, 9).Text = "k€" Then
ActiveSheet.Range(Cells(52, 10)).Locked = True
Else
ActiveSheet.Range(Cells(52, 10)).Locked = False
End If
If Intersect(ActiveSheet.Cells(53, 9), Target) Is Not Nothing Then
If ActiveSheet.Cells(53, 9).Text = "k€" Then
ActiveSheet.Range(Cells(53, 10)).Locked = True
Else
ActiveSheet.Range(Cells(53, 10)).Locked = False
End If
End If
End Sub

 

[Takae]

If the changed cell is in Range("I32:I53"), next to the cell(columnJ) will change.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("I32:I53")) Is Not Nothing Then
        Exit Sub
    Else
        Select Case Target.Value
            Case [COLOR=#333333] "k€"[/COLOR]
                .Target.Offset(0, 1).Locked = True
            Case Else
                .Target.Offset(0, 1).Locked = False
        End Select
    End If
End Sub

 

[AlphaFrog]

Try something like this...

[color=darkblue]Private[/color] [color=darkblue]Sub[/color] Worksheet_Change([color=darkblue]ByVal[/color] Target [color=darkblue]As[/color] Range)
    [color=darkblue]Dim[/color] cell [color=darkblue]As[/color] Range
    [color=darkblue]With[/color] Range(Cells(32, 9), Cells(53, 9))
        [color=darkblue]If[/color] [color=darkblue]Not[/color] Intersect(.Cells, Target) [color=darkblue]Is[/color] [color=darkblue]Nothing[/color] [color=darkblue]Then[/color]
            [color=darkblue]For[/color] [color=darkblue]Each[/color] cell [color=darkblue]In[/color] Intersect(.Cells, Target)
                cell.Offset(, 1).Locked = cell.Text = "k€"
            [color=darkblue]Next[/color] cell
        [color=darkblue]End[/color] [color=darkblue]If[/color]
    [color=darkblue]End[/color] [color=darkblue]With[/color]
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

Note: the Worksheet_Change event doesn't trigger when a formula calculates. It triggers when the user makes a change to a cell. So if you have formulas in Range(Cells(32, 9), Cells(53, 9)), then this wouldn't work.