Auto Lock data from change ?

[redd]

Col. D is Data.Can I lock cell once Data is entered.If I need to change Data I would Unprotect Sheet. Eg.D4 data entered ,then cell auto locks

 

[Smitty]

Sure:

<font face=Courier New><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Sub</SPAN> Worksheet_Change(<SPAN style="color:#00007F">ByVal</SPAN> Target <SPAN style="color:#00007F">As</SPAN> Range)
    <SPAN style="color:#007F00">'   Code goes in the Worksheet specific module</SPAN>
    <SPAN style="color:#00007F">Dim</SPAN> rng <SPAN style="color:#00007F">As</SPAN> Range
        <SPAN style="color:#007F00">'   Set Target Range</SPAN>
        Set rng = Range("D:D")
             <SPAN style="color:#007F00">'   Only look at single cell changes</SPAN>
            <SPAN style="color:#00007F">If</SPAN> Target.Count > 1 <SPAN style="color:#00007F">Then</SPAN> <SPAN style="color:#00007F">Exit</SPAN> <SPAN style="color:#00007F">Sub</SPAN>
            <SPAN style="color:#007F00">'   Only look at that range</SPAN>
            <SPAN style="color:#00007F">If</SPAN> Intersect(Target, rng) <SPAN style="color:#00007F">Is</SPAN> <SPAN style="color:#00007F">Nothing</SPAN> <SPAN style="color:#00007F">Then</SPAN> <SPAN style="color:#00007F">Exit</SPAN> <SPAN style="color:#00007F">Sub</SPAN>
            <SPAN style="color:#007F00">'   Action if Condition(s) are met</SPAN>
            ActiveSheet.Unprotect "PasswordHere"
                Target.Locked = <SPAN style="color:#00007F">True</SPAN>
            ActiveSheet.Protect "PasswordHere"
<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>

Just make sure to unlock column D beforehand or you won't be able to make any entries to begin with...

HTH,

Smitty

 

[Boller]

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, cell As Range
Set rng = Intersect(Target, [D:D])
If rng Is Nothing Then Exit Sub
For Each cell In rng
    If cell = "" Then
        cell.Locked = False
    Else
        cell.Locked = True
    End If
Next
End Sub