Locking and unlocking cells

[montecarlo2079]

I have a form that calculates a score of an individual.

There is one section that a person can earn a score on one section or the other.

So if there is a score in cell A1, then I should not be allowed to enter anything in cell B1.

And Vice Versa

I found this but it only works one way

Private Sub Worksheet_Change(ByVal Target As Range) 
    If InRange(ActiveCell, Range("A1")) Then 
        ActiveSheet.Unprotect 
        ActiveCell.Offset(-1, 0).Locked = True 
        ActiveSheet.Protect 
    Else: End If 
    End Sub


Function InRange(Range1 As Range, Range2 As Range) As Boolean 
     'returns True if Range1 is within Range2
    Dim InterSectRange As Range 
    Set InterSectRange = Application.Intersect(Range1, Range2) 
    InRange = Not InterSectRange Is Nothing 
    Set InterSectRange = Nothing 
End Function

This doesnt seem to work.

Any suggestions?

 

[VoG]

Try

Private Sub Worksheet_Change(ByVal Target As Range)
Select Case Target.Address(False, False)
    Case "A1"
        Me.Unprotect
        Target.Offset(, 1).Locked = True
        Me.Protect
    Case "B1"
        Me.Unprotect
        Target.Offset(, -1).Locked = True
        Me.Protect
End Select
End Sub

 

[montecarlo2079]

it doesnt work, it allows me to enter values in one, the other or both.

I can only have one value in either a1 or b1, but not both

 

[VoG]

It works perfectly here. Where did you put the code - you need to right click the sheet tab, select View Code and paste in the code.

As presently coded it applies only to A1 and B1, not the whole of those columns. That could easily be changed.

 

[montecarlo2079]

I think I got it
Private Sub Worksheet_Change(ByVal Target As Range)
If Range("f24") > 0 And Range("f26") > 0 Then
MsgBox "ONLY ONE SCORE IS ALLOWED FOR THIS SECTION"
Range("f24").Select
Selection.ClearContents
Range("f26").Select
Selection.ClearContents
Range("f24").Select
End If
If Range("f26") > 0 And Range("f24") > 0 Then
MsgBox "ONLY ONE SCORE IS ALLOWED FOR THIS SECTION"
Range("f24").Select
Selection.ClearContents
Range("f26").Select
Selection.ClearContents
Range("f24").Select
End If

End Sub