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]

*** this is an answer for @jrhrcomp1 ***

See if this example does what you want:

' this goes at the sheet module
Private Sub Worksheet_Activate()


' protect range when activating sheet
Me.Cells.Locked = False
Me.Range("d1:d10").Locked = True
Me.Protect "1234", , , , True


End Sub


Private Sub Worksheet_Change(ByVal Target As Range)


Dim auth(), res
If Target = Range("h2") And Target.Value <> "" Then
    auth = Array("user1", "user2", "user3")
    res = Filter(auth, Target.Value, False, vbTextCompare)
    ' unprotect if authorized user is entered at H2
    If UBound(res) <> UBound(auth) Then Me.Unprotect "1234"
End If
    
End Sub

 

[kdsrahi]

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

I was trying to use this code and it worked perfectly on 1 sheet. but my requirement is apply this code to all the sheets in workbook. How to do it? please suggest.

 

[Worf]

Please test this:

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)
Dim Sh As Worksheet
For Each Sh In Me.Worksheets
    Set wr = Sh.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
Next
End Sub


Private Sub Workbook_Open()
    Initial
End Sub


Sub Initial()
Dim Sh As Worksheet
For Each Sh In Me.Worksheets
    Sh.Protect Password:="pw", userinterfaceonly:=True
    Set wr = Sh.Range("a1:a20")
    wr.Interior.ColorIndex = xlNone
    For Each wcell In wr
        wcell.Locked = False
        If wcell.Value <> "" Then wcell.Locked = True
    Next
Next
End Sub


Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Not Intersect(Sh.Range("a1:a20"), Target) Is Nothing Then Target.Interior.ColorIndex = 34
End Sub

 

[Bobilly23]

I am getting an error with the "Sub Initial ()" Line.

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:r" & LastRow(Me.Name, "yes"))

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("PRA")
ws.Protect Password:="pw", userinterfaceonly:=True
Set wr = ws.Range("a1:w" & LastRow(Me.Name, "yes"))
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(Prioritization - tool - v4).Sheets(PRA).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

 

[Worf]

What line is highlighted when the error occurs, the first one? What is the error message?
Possible causes are:

- Cell contains an error value
- Cell is part of an array

Try this new version:

Sub Initial()
Set ws = ThisWorkbook.Worksheets("PRA")
ws.Protect Password:="pw", userinterfaceonly:=True
Set wr = ws.Range("a1:w" & LastRow(Me.Name, "PRA"))
wr.Interior.ColorIndex = xlNone
On Error Resume Next
For Each wcell In wr
    wcell.Locked = False
    If wcell.Value <> "" Then wcell.Locked = True
    If Err.Number > 0 Then
        MsgBox wcell.Address, vbInformation, "Error " & Err.Number
        Err.Clear
    End If
Next
On Error GoTo 0
End Sub

 

[Sergey]

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

Hi, this macro works great for me, but filters in row 3 is not working. Also i need to have unlocked column J (comments) where users can edit data anytime. May be it's possible to make an exception for that row and columns (make it always unlocked)? Could you please help me with that?

 

[Worf]

Hi and welcome to the Board

Sub Initial()
' allows editing at row 3 and column J
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 Not WorksheetFunction.IsErr(wcell) Then
        If wcell <> "" And wcell.Row <> 3 And wcell.Column <> 10 Then wcell.Locked = True
    End If
Next
End Sub

 

[Sergey]

Hi and welcome to the Board

Sub Initial()
' allows editing at row 3 and column J
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 Not WorksheetFunction.IsErr(wcell) Then
        If wcell <> "" And wcell.Row <> 3 And wcell.Column <> 10 Then wcell.Locked = True
    End If
Next
End Sub

Hi, thank you very much, but there is a runtime error 1004:

For Each wcell In wr
[COLOR=#ff0000]    wcell.Locked = False[/COLOR]
    If Not WorksheetFunction.IsErr(wcell) Then
        If wcell <> "" And wcell.Row <> 3 And wcell.Column <> 10 Then wcell.Locked = True
    End If

 

[Worf]

Hi

One possible cause is the existence of merged cells, please confirm this hypothesis by running the following:

Sub Initial()
' allows editing at row 3 and column J
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
On Error Resume Next
For Each wcell In wr
    wcell.Locked = False
    If Err.Number > 0 Then
        MsgBox "Cell " & wcell.Address & vbLf & "Merged Area " & wcell.MergeArea.Address, _
        vbCritical, "Error " & Err.Number
        On Error GoTo 0
        Exit Sub
    End If
    If Not WorksheetFunction.IsErr(wcell) Then
        If wcell <> "" And wcell.Row <> 3 And wcell.Column <> 10 Then wcell.Locked = True
    End If
Next
End Sub

 

[leongheng70]

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
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

I have tried the above code, but when i reopen the file after saving, i was still able to edit the cell, i need to re-run the macro again for it to work, any ideas what had happen ?