Auto lock cells after data entry when file saved...

[cjcass]

Hi, I have a table range A5:AA1000 in a data entry worksheet… the file will be sat on a shared drive and will be accessed by different people throughout the day. I want the data entry worksheet to be locked and protected so people can only access and enter data into cells J5:N1000 in the table. When they have entered data into chosen cells and then saved the file, I want the cells they have entered data into to be locked so the next person opening the file can’t access them and make any changes.</SPAN>

Is there some VB code I can input into the worksheet that will execute this locking out of the cells when the user saves the file? Am using Excel 2007.</SPAN>

Many thanks indeed for your help…</SPAN>

 

[Jaafar Tribak]

Give the range A5:AA1000 the Name of InputRange and put the following code in the Thisworkbook module :

Option Explicit

Private bRangeEdited As Boolean
Private WithEvents ws As Worksheet


Private Sub Workbook_Open()
    Set ws = Range("InputRange").Parent
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim sMSG As String
    
    sMSG = "saving the workbook will lock the cells you have entered data into." & vbLf
    sMSG = sMSG & "Do you want to go ahead ?"
    If Not bRangeEdited Then GoTo Xit
    If Not Me.ReadOnly Then
        With Range("InputRange")
            If MsgBox(sMSG, vbExclamation + vbYesNo) = vbNo Then
                Cancel = True
                GoTo Xit
            End If
            .Parent.Unprotect "password"
            If .SpecialCells(xlCellTypeBlanks).Address <> .Address Then
                .SpecialCells(xlCellTypeConstants).Locked = True
                bRangeEdited = False
            End If
            .Parent.Protect "password"
        End With
    End If
Xit:
End Sub

Private Sub ws_Change(ByVal Target As Range)
    If Not Intersect(Range("InputRange"), Target) Is Nothing Then
        bRangeEdited = True
    End If
End Sub

Now save and close the workbook so it is ready and functional next time you open it.

I assumed the following :
1- Workbook is not shared.
2- The worksheet is protected with the password "password" - change as required.

 

[cjcass]

Works brilliantly!!
Thank you very much indeed for your assistance with this.
Best Regards,
Chris

 

[cjcass]

Hi,

Wondered if I could trouble you once more?

Having played with my spreadsheet and tested it, it works very well and is robust but I notice that if a cell has been locked after saving and the cell entry is then later deleted by the administrator (eg. a user makes a mistake, contacts the administrator who then deletes the entry) the cells remains locked after re-saving even though it no longer has an entry in it. I can brief the administrator that he must unlock any cells that he has deleted entries from but wondered if there was a simpe workaround to avoid him having to remember this?

Regards,
Chris

 

[Jaafar Tribak]

I have added a checkbox (CheckBox1) for the administrator so that when he clicks the box he is prompted to enter the admin password after which he can freely manage the worksheet .
I have also added a userform (UserForm1) with a textbox (TextBox1) which is where the administrator will be entering the admin password. The reason I have used a userform-textbox is so that the password remain masked/hidden from the viewer when being typed.

The worksheet protection and Admin passwords are both declared at the top of the ThisWorkbook module so that they can be easily edited/changed if needed.

I would password protect the workbook VBProject so that no user can see the code or passwords.

Workbook demo.


1- Code in the ThisWorkbook module:

Option Explicit

Public sTxtBoxPassw As String

Private Const ADMIN_PASSWORD As String = "ADMIN" 'change passwords as required.
Private Const WORKSHEET_PASSWORD As String = "password"
Private bRangeEdited As Boolean
Private bAdmin As Boolean
Private WithEvents ws As Worksheet
Private WithEvents ChckBx  As MSForms.CheckBox

Private Sub Workbook_Open()
    With Range("InputRange")
        Set ws = .Parent
        Set ChckBx = .Parent.CheckBox1
        ChckBx.Caption = "Adminitrator"
        ChckBx.Value = False
    End With
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim sMSG As String
    sMSG = "saving the workbook will lock the cells in the 'InputRange' ." & vbLf
    sMSG = sMSG & "Do you want to go ahead ?"
    If Not bRangeEdited Or bAdmin Then GoTo Xit
    If Not ReadOnly Then
        With Range("InputRange")
            If MsgBox(sMSG, vbExclamation + vbYesNo) = vbNo Then
                Cancel = True
                GoTo Xit
            End If
            .Parent.Unprotect WORKSHEET_PASSWORD
            If .SpecialCells(xlCellTypeBlanks).Address <> .Address Then
                .SpecialCells(xlCellTypeConstants).Locked = True
                bRangeEdited = False
            End If
            .Parent.Protect WORKSHEET_PASSWORD
        End With
    End If
Xit:
End Sub

Private Sub ws_Change(ByVal Target As Range)
    If Not Intersect(Range("InputRange"), Target) Is Nothing Then
        bRangeEdited = True
    End If
End Sub

Private Sub ChckBx_Change()
    With ChckBx
        Select Case .Value
            Case True
                If EnterAdminPassword = UCase(ADMIN_PASSWORD) Then
                    bAdmin = True
                    Range("InputRange").Parent.Unprotect WORKSHEET_PASSWORD
                Else
                    ChckBx.Value = False
                    MsgBox "Wrong Adim Password", vbCritical
                End If
            Case Else
                bAdmin = False
                Range("InputRange").Parent.Protect WORKSHEET_PASSWORD
        End Select
    End With
End Sub

Private Function EnterAdminPassword() As String
    UserForm1.Show vbModal
    EnterAdminPassword = UCase(sTxtBoxPassw)
End Function

2- Code in the userForm module :

Option Explicit

Private Sub UserForm_Initialize()
    Caption = "Enter Admin Password"
    With TextBox1
        .BackColor = vbYellow
        .PasswordChar = "*"
        .Left = 0
        .Top = 0
        .Width = 150
        .Height = 20
        Width = .Width
        Height = .Height * 2
    End With
End Sub

Private Sub TextBox1_KeyDown( _
ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = 13 Then
        ThisWorkbook.sTxtBoxPassw = TextBox1.Text
        Unload Me
    End If
End Sub

 

[fantasticsemi]

I've a similar situation if you can help me up with, I have a work book work several sheets ... All I need is when a user edit in a sheet and then click save all the cells ranging from A1:O30 in this active sheet will be locked
All the sheets are already password protected
Thanks again for your help

 

[RoWa74]

Hi all,

I am new to this forum and I have a question. I used the first VB code posted in this thread to auto lock cell after they have been saved and it works like a charm.
Now my question is that i found out that it doesnt work for check boxes. Is there a way to alter the code so that it will also apply on check boxes being checked?

I hope that there is somebody out there that can enlighten me.

Kind regards,

Rowa

 

[bpiroma]

Hi,

Is there a possibility to include in the macro that after entering the data then they click ENTER, the worksheet will be auto saved?

Thanks.

Roma

 

[SUPER SUPER]

Hi, I have a worksheet… the file will be set on a shared drive and will be accessed by different people throughout the day. I want the data entry worksheet to be locked and protected so people can only access and enter data in blank cells. When they have entered data into blank cells and then saved the file, I want the cells they have entered data into to be locked so the next person opening the file can’t access them and make any changes.but i want this code specially in shared workbook and users also hide unhide columns and freeze panes .users. cant see the password .and any wrong entry typed from user so i want to change that entry without remove share workbook. Am using Excel 2007.so please please tell me...iam very excited. also thanks a lot in advance.

 

[SUPER SUPER]

I have send so many post but iam not recieved any answser , why ?