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]

Place the following before that line:

If ActiveSheet.Name <> "Enter Data Here" Then Exit Sub
Set ws = ThisWorkbook.Worksheets("Enter Data Here")

 

[ROSH22]

Nope that didnt work, I found this code that works

However, I do not know how to add a password to it, can you help?


code for workbook event:

Code:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Dim LastRow As Long LastRow = ThisWorkbook.Worksheets("Enter Data Here").Cells(Rows.Count, 1).End(xlUp).Row Names.Add Name:="LastRow", RefersTo:=LastRow Worksheets(Worksheets.Count).Activate Worksheets("Enter Data Here").Activate End Sub</pre>
code for worksheet event:

Code:

Private Sub Worksheet_Activate() Dim BlockedArea As Range, FormulasRange As Range, ConstantsRange As Range ActiveSheet.Unprotect Cells.Locked = False On Error Resume Next With ActiveSheet.Cells(1, 1).Resize(Evaluate("LastRow"), 21) Set ConstantsRange = .SpecialCells(xlCellTypeConstants) Set FormulasRange = .SpecialCells(xlCellTypeFormulas) End With Set BlockedArea = ConstantsRange Set BlockedArea = Union(ConstantsRange, FormulasRange) On Error GoTo 0 BlockedArea.Locked = True ActiveSheet.Protect End Sub</pre>

 

[ROSH22]

I will post it properly

For Workbook

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)  Dim LastRow As Long LastRow = ThisWorkbook.Worksheets("Enter Data Here").Cells(Rows.Count, 1).End(xlUp).Row  Names.Add Name:="LastRow", RefersTo:=LastRow  Worksheets(Worksheets.Count).Activate Worksheets("Enter Data Here").Activate  End Sub</pre>

For worksheet

Private Sub Worksheet_Activate()  Dim BlockedArea As Range, FormulasRange As Range, ConstantsRange As Range  ActiveSheet.Unprotect  Cells.Locked = False  On Error Resume Next With ActiveSheet.Cells(1, 1).Resize(Evaluate("LastRow"), 21)     Set ConstantsRange = .SpecialCells(xlCellTypeConstants)     Set FormulasRange = .SpecialCells(xlCellTypeFormulas) End With  Set BlockedArea = ConstantsRange Set BlockedArea = Union(ConstantsRange, FormulasRange) On Error GoTo 0  BlockedArea.Locked = True  ActiveSheet.Protect  End Sub</pre>

 

[Worf]

Nope that didnt work, I found this code that works

My code worked fine for me, I only post tested stuff. Naturally other workbooks and Excel versions may pose some trouble...

I'm off to bed now, tomorrow we can decide whether to stick to my proposal or change to this new one.

 

[ROSH22]

Ok Thanks for your help!

If you are able to help me add a password protect to this one I would be very greatful!

Thanks

 

[Worf]

See if this does it.

Private Sub Worksheet_Activate()

    Dim BlockedArea As Range, FormulasRange As Range, ConstantsRange As Range
    ActiveSheet.Unprotect Password:="pw"
    Cells.Locked = False
    On Error Resume Next
    With ActiveSheet.Cells(1, 1).Resize(Evaluate("LastRow"), 21)
        Set ConstantsRange = .SpecialCells(xlCellTypeConstants)
        Set FormulasRange = .SpecialCells(xlCellTypeFormulas)
    End With
    Set BlockedArea = Union(ConstantsRange, FormulasRange)
    On Error GoTo 0
    BlockedArea.Locked = True
    ActiveSheet.Protect Password:="pw"

End Sub

 

[Kinngs]

Hi,
I have a similar query, But not so complicated.
I've done all the validations set but i want user to be allowed to select only once. once an entry is made in the empty cell, its should be locked.
Sheet is protected with password "password1"
Range of cells to put the VBA on "Column H & column K"
Also once an entry is made the sheet should be saved automatically.

Regards,
Taran

 

[Worf]

Please test this:

Option Explicit
' this code goes at the Sheet module    <---------
Private Sub Worksheet_Activate()
    Dim BlockedArea As Range, FormulasRange As Range, ConstantsRange As Range
    ActiveSheet.Unprotect Password:="password1"
    Cells.Locked = False
    On Error Resume Next
    With ActiveSheet.Cells(1, 1).Resize(LastRow(ThisWorkbook.Name, ActiveSheet.Name), 12)
        Set ConstantsRange = .SpecialCells(xlCellTypeConstants)
        Set FormulasRange = .SpecialCells(xlCellTypeFormulas)
    End With
    Set BlockedArea = Union(ConstantsRange, FormulasRange)
    On Error GoTo 0
    BlockedArea.Locked = True
    ActiveSheet.Protect Password:="password1", userinterfaceonly:=True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
    ' monitors only columns H & K
    If Target.Column <> 8 And Target.Column <> 11 Then Exit Sub
    If Target.Value <> "" Then
        Target.Locked = True
        ThisWorkbook.Save
    End If
           
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

 

[allawati9]

good evening
i want a code to auto lock the cell in the worksheet in except in few pages ( i want to name it in the code)
auto lock is after saving
i dont know where to put the code (page or worksheet)

the range of the cell is any the cell in the sheet
the password is 1234

thanks alot

 

[Worf]

Hello and welcome to the Board!

Sorry for the delayed answer. See if this is what you want:

Option Explicit


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




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


Dim NoLock(), ws As Worksheet, res


NoLock = Array("Rory", "Peter")             ' these sheets will not be locked


For Each ws In ThisWorkbook.Worksheets
    
    res = Filter(NoLock, ws.Name, False, vbTextCompare)
    If UBound(res) = UBound(NoLock) Then    ' not a member of NoLock
        ws.Cells.Locked = True
        ws.Protect Password:="1234", userinterfaceonly:=True
    End If
        
Next


End Sub