VBA to protect cells before today's date

[abhirupganguli123]

Hello,

I have a spreadsheet with row wise dates in column A.
I need a vba code to automatically protect cells with password from column A to J (row wise) when Today's date is passed. Could anyone help me with a code? The code should not start with Sub "Private Sub Worksheet_Change" as I already have a code written in the worksheet module with same sub, so as I know two Change mode codes will not work in a same module.

I have got a code, but it is not working as whenever I double click on a cell it gets opened. On the fist double click it says protected, but on the second double click it gets opened. Could you please rectify this code or provide a new one ?


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Range("A" & Selection.Row).Value < Date Then
ActiveSheet.Protect Password:="accountancy"
MsgBox "Only today's time can be edited!"
ElseIf Range("A" & Selection.Row).Value >= Date Then
ActiveSheet.Unprotect Password:="accountancy"
ActiveSheet.EnableSelection = xlNoRestrictions
End If

End Sub

 

[mse330]

abhirupganguli123, try the below code & place it under "ThisWorkbook" ... Basically this will check & lock the cells on file opening

Try it out & let me know if that's what you are looking for - Just make sure to change the sheet name in the code

Private Sub Workbook_Open()

' This section to find the sheet index number
Dim ShtName As String
ShtName = "Sheet1"  ' Change the "Sheet1" part to the name of your sheet

Dim ws As Worksheet, ShtNo As Integer
For Each ws In Worksheets
    If ws.Name = ShtName Then
        ShtNo = ws.Index
    End If
Next

' This section to Unprotect the sheet & unlock all cells
With Sheets(ShtNo)
    .Unprotect "accountancy"
    .Cells.Locked = False
End With


' This section to define the data range & loop throught the rows to check the date & lock the cells accordingly
Dim lRow As Long, x As Long
lRow = Sheets(ShtNo).Range("A" & Rows.Count).End(xlUp).Row

For x = 2 To lRow
    If Sheets(ShtNo).Cells(x, 1).Value < Date Then
        Sheets(ShtNo).Range(Cells(x, 1), Cells(x, 10)).Locked = True  ' Cells(x, 10) the 10 represents the 10th column which is J
    End If
Next x

' This last section to protect the sheet again
Sheets(ShtNo).Protect "accountancy"


End Sub

 

[abhirupganguli123]

Thank you, this is exactly what I needed.

But I want to have a couple of additions to it -

1) I need to have this locking in multiple sheets, is there a was to put multiple sheet names ?
2) I want to show a message when people click on a prior date cell - "Only Today's date can be edited".

Can these two facilities be added in the code ?

Thanks

 

[mse330]

You are welcome. I think yes we can do these two additional requirements but do all the sheets that you want to protect follow the same structure? Where you have the dates in columns A & the data goes to column J ? Because if it differs, then I need to know the structure to be able to modify the code to cater for all sheets

 

[abhirupganguli123]

You are welcome. I think yes we can do these two additional requirements but do all the sheets that you want to protect follow the same structure? Where you have the dates in columns A & the data goes to column J ? Because if it differs, then I need to know the structure to be able to modify the code to cater for all sheets

Yes, the data structure and format are same in all the sheets I want to protect. Dates are in column A, and the data goes to column J.

 

[mse330]

I have changed the code to loop through all sheets. All you need to do is to put the sheets' names in the array

Private Sub Workbook_Open()

Dim ws As Worksheet
Set WSArray = Sheets(Array("Sheet1", "Sheet3"))  ' Define the sheets names that you need to protect

For Each ws In WSArray

    ' This section to Unprotect the sheet & unlock all cells
    With ws
        .Unprotect "accountancy"
        .Cells.Locked = False
    End With
        
    ' This section to define the data range & loop throught the rows to check the date & lock the cells accordingly
    Dim lRow As Long, x As Long
    lRow = ws.Range("A" & Rows.Count).End(xlUp).Row
    
    For x = 2 To lRow
        If ws.Cells(x, 1).Value < Date Then
            ws.Range(ws.Cells(x, 1), ws.Cells(x, 10)).Locked = True  ' Cells(x, 10) the 10 represents the 10th column which is J
        End If
    Next x
    
    ' This last section to protect the sheet again
    ws.Protect "accountancy"
Next

End Sub

Regarding changing the default excel message when trying to access locked cells, you can use the below code. However, this will only work when double-clicking the cell but not in other ways such as typing directly in the formula address bar or pressing F2 in the keyboard. Also, you have to place this code in all the sheets that you want this message to appear in

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Target.Locked = True Then
    MsgBox "Prior dates data can not be edited/changed", vbExclamation ' You can change the message text as desired
    Cancel = True
End If

End Sub