Auto Lock Cells after Data Entry AND Save

[ROSH22]

Firstly, I know 0 about programming or VBA, but I found this code which auto locks cells after you enter data in them.









Private Sub Worksheet_Change(ByVal Target As Excel.Range)
' Place this code in the worksheet code module. ' The subroutine unprotects the sheet and IF an entry is made ' in an empty ("") cell, the cell is locked and then the ' sheet's protection is turned back on. Any further ' attempts to edit the cell generate the password msgbox. ' You can set the range to one cell ("A1") or an area ("A1:Z300"). ' 1. Use Format - Cells - Protection to unlock the cells ' in the range where one time entries are to be allowed. ' 2. Protect the worksheet with the same password as ' you use twice in the following subroutine (thepassword).
On Error GoTo justenditall
Application.EnableEvents = False If Not Intersect(Target, Range("A1:A20")) Is Nothing Then If Target.Value <> "" Then ActiveSheet.Unprotect Password:="thepassword" Target.Locked = True End If End If
ActiveSheet.Protect Password:="thepassword"
justenditall: Application.EnableEvents = True End Sub






Now I want to make this only work when the file is saved. For example, when an employee opens up the file he or she is able to enter any new data, but not edit old data, and once saved, they will not be able to edit the data they just entered.
I hope this makes sense.
Thanks!

 

[Worf]

Hello and welcome to the Board

Please confirm that this is what you want:

• Users can only input data at empty cells.
• Users cannot edit old data.
• Users should be able to edit their new data, until they save the file.

What Excel version are you using?

 

[Worf]

This first version will highlight new entries; after saving they become old entries and cannot be changed without a password.
If this is not the desired behaviour please post back.

Option Explicit

' this code goes at the Sheet module    <---------

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A1:A20")) Is Nothing Then _
        Target.Interior.ColorIndex = 34
End Sub

Option Explicit
Dim wr As Range, wcell As Range

' this code goes at ThisWorkbook module     <--------

Private Sub Workbook_Activate()
    Initial
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Set wr = ThisWorkbook.Worksheets("S2").Range("a1:a20")  ' editable range
For Each wcell In wr
    Select Case wcell.Interior.ColorIndex
        Case xlNone
            ' no action
        Case Else
             wcell.Interior.ColorIndex = xlNone
             If wcell.Value <> "" Then wcell.Locked = True      ' no more changes
    End Select
Next
End Sub

Private Sub Workbook_Open()
    Initial
End Sub

Sub Initial()

ThisWorkbook.Worksheets("S2").Protect Password:="pw", userinterfaceonly:=True
Set wr = ThisWorkbook.Worksheets("S2").Range("a1:a20")
wr.Interior.ColorIndex = xlNone

For Each wcell In wr
    wcell.Locked = False
    If wcell.Value <> "" Then wcell.Locked = True
Next
    
End Sub

 

[ROSH22]

Thanks for this.

I am getting a debug error when I try to save.

To make it simpler for you, I want all columns from A to AZ locked

And my sheet name is 'Enter Data Here'

Thanks!

 

[ROSH22]

Sorry and I am using Excel 2010.

Thanks!

 

[ROSH22]

So I changed S2 to "Enter Data Here"

and I changed my cell range.

I got a runtime error message 13 and also now the entire sheet becomes locked, not only the cells that I have filled in.

Thanks

 

[Worf]

So I changed S2 to "Enter Data Here"
and I changed my cell range.
I got a runtime error message 13 and also now the entire sheet becomes locked, not only the cells that I have filled in.
Thanks

What code line is highlighted when you get the error?
This method requires a sheet password (it's on the code), you can remove it anytime at the Ribbon > Revision > Unprotect.
I understand the users may only have access to the editable range, right?

 

[ROSH22]

OK so I am not getting the runtime error anymore. What I did was first change the cells A1:W65536 to 'unlcocked', then I changed the range in your code from A1:W65536 and changed 'S2' to the name of my sheet which was 'Enter Data Here'

What happens now is that a cell that I add data to becomes highlighted. However, after I press save I am still able to edit the data in those cells.

What I need to be able to do is to add information, and only be able to edit it before I save. Any information already on the sheet from the last save should be un-erasable. Once I press save, all the cells with newly added data in them should be locked along with the rest.

 

[Worf]

Please test this new version. I'm referencing only the used range, because it gets slow to deal with 65000 x 20 cells.
Note that you must keep the sheet password protected for this to work properly.

Option Explicit

' this code goes at the Sheet module    <---------

Private Sub Worksheet_Change(ByVal Target As Range)
      
    If Target.Column < 24 Then Target.Interior.ColorIndex = 34
           
End Sub

Option Explicit
Public wr As Range, wcell As Range, fr As Range, ws As Worksheet

' this code goes at ThisWorkbook module     <--------

Private Sub Workbook_Activate()
    Initial
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

Set wr = ws.Range("a1:w" & LastRow(Me.Name, "Enter Data Here"))

For Each wcell In wr
    Select Case wcell.Interior.ColorIndex
        Case xlNone
            ' no action
        Case Else
             wcell.Interior.ColorIndex = xlNone
             If wcell.Value <> "" Then wcell.Locked = True      ' no more changes
    End Select
Next
End Sub

Private Sub Workbook_Open()
    Initial
End Sub

Sub Initial()

Set ws = ThisWorkbook.Worksheets("Enter Data Here")
ws.Protect Password:="pw", userinterfaceonly:=True
Set wr = ws.Range("a1:w" & LastRow(Me.Name, "Enter Data Here"))
wr.Interior.ColorIndex = xlNone

For Each wcell In wr
    wcell.Locked = False
    If wcell.Value <> "" Then wcell.Locked = True
Next
    
End Sub

Public Function LastRow(wname$, which$) As Long
    Workbooks(wname).Sheets(which).Activate
    If WorksheetFunction.CountA(Cells) = 0 Then
        LastRow = 0
        Exit Function
    End If
    LastRow = Cells.Find(What:="*", After:=[a1], SearchOrder:=xlByRows, _
    SearchDirection:=xlPrevious).Row
End Function

 

[ROSH22]

When trying to save

I got a debug error

Pointing to this line

Set wr = ws.Range("a1:w" & LastRow(Me.Name, "Enter Data Here"))