Allow entry only once

[siddharth_kale]

Hello all,

I have requirement wherein each cell should be allowed to edit only once.

This has to be done for a range of cells. For eg. A1:A10, C1:C10.

I have found the below code but it is not working as desired. The second time when you enter in the same column (any other cell) it doesnt seem to allow, which is should not be the case.

Any other cell should be allowed, again only once.

Any help is appreaciate.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myChangeOnceCells As Range
Dim myCell As Range
Dim pwd As String

pwd = "hi"

Set myChangeOnceCells = Me.Range("A1,A3,A6,D7,C3,B4,B6")

If Intersect(Target.Cells, myChangeOnceCells) Is Nothing Then Exit Sub

Me.Unprotect Password:=pwd
For Each myCell In Intersect(Target.Cells, myChangeOnceCells).Cells
myCell.Locked = True
Next myCell
Me.Protect Password:=pwd

End Sub

 

[doofusboy]

It would seem to me that in order to meet your objective you'd need to know for each cell in the specified range whether the entry being made is an initial entry, the first edit, or any additional edit after the first edit.

One way to do this is to keep track [perhaps in a hidden column] how many entries have been attempted for each cell in the specified range.

The following code will allow an initial entry and one edit. After that, it basically just refuses to update the cell. To test the code, I created a named range ["MyCells"] for A1:A5. I used column B to keep track of how many entries were made to the cells in the named range. Worked just fine.

Of course you'll need to edit the code for your ranges and for where you decide to record what I was recording in column B.

Public Sub Worksheet_Change(ByVal Target As Range)
    If Application.Intersect(Target, Range("MyCells")) Is Nothing Then Exit Sub
    If Target.Offset(0, 1).Value = 2 Then         'any entry after first edit
        Application.Undo
        Exit Sub
    ElseIf Target.Offset(0, 1).Value = 1 Then    'first edit
        Target.Offset(0, 1).Value = 2
    Else
        Target.Offset(0, 1).Value = 1                'initial entry
    End If
End Sub

 

[siddharth_kale]

Hello,

Thanks for replying.

I think you did not understand it correctly but its my bad, probably did not write properly.

Here is is again: Once an entry is made in the cell and saved it should not be editable the next time. I have the below code which works like a charm but the effect is immediate. I would like the same effect after the workbook is saved. Could you advice?

April is the original sheet and AprilCheck is a copy of the sheet.

======================================================
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range

Application.EnableEvents = False
For Each c In Target
With Sheets("AprilCheck").Range(c.Address)
If .Value <> "" Then
c.Value = .Value
Else
.Value = c.Value
End If
End With
Next c
Application.EnableEvents = True
End Sub
======================================================

 

[Michael M]

Hi
You may be able to modify the ranges to suit in you change event.

For Each r In Range(YOUR RANGE)
    If r.Value <> "" = True Then
        r.Locked = True
    End If
Next r

 

[Michael M]

Hi
You may be able to modify the ranges to suit in you change event.

For Each r In Range(YOUR RANGE)
    If r.Value <> "" = True Then
        r.Locked = True
    End If
Next r