Lock cells on the basis of date VBA

[Rajesh Kr Joshi]

Hi, I am looking for a macro code to lock cell basis date. In the attached sheet i have employes who enters the data on daily basis. I wants to lock the cells once it is 2 days old from todays date, for example i wants t-he cells that are under Sep-1 to be locked after Sep 3rd (=today()-2) .
Hope to have a solution from this fourmCell Lock.xlsx

Thanks
Rajesh

[Admin]

Hi Rajesh,

Please don't post question on Tips & Tricks forum. That forum meant to be provide cool tips and tricks only.
If you have a specific question please post the question on the main forum.

Paste the following code in ThisWorkbook module of your workbook.

Private Sub Workbook_Open()
    
    Dim wksTarget       As Worksheet
    Dim rngDate         As Range
    Dim rngData         As Range
    Dim c               As Long
    Dim LastRow         As Long
    Dim LastCol         As Long
    
    Const RangeToLock   As String = "C:AG" '<<  adjust to suit
    Const Pwd           As String = "pwd"
    
    Set wksTarget = ThisWorkbook.Worksheets("Sheet1") '<<  adjust to suit
    
    If Not blnUnlockedAllCells Then
        wksTarget.Cells.Locked = False
        blnUnlockedAllCells = True
        wksTarget.Protect Password:=Pwd, userinterfaceonly:=True
    End If
    
    With wksTarget
        LastRow = .Range("a" & .Rows.Count).End(xlUp).Row
        LastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
        Set rngData = wksTarget.Range("a2", .Cells(LastRow, LastCol))
    End With
    
    For c = 3 To rngData.Columns.Count
        If CDate(rngData(1, c)) <= Date - 2 Then
            On Error Resume Next
            rngData.Columns(c).SpecialCells(2).Locked = True
            On Error GoTo 0
        End If
    Next
    
End Sub

adjust the sheet name and the range.

[Rajesh Kr Joshi]

Hi, I am looking for a macro code to lock cell basis date. In the attached sheet i have employes who enters the data on daily basis. I wants to lock the cells once it is 2 days old from todays date, for example i wants t-he cells that are under Sep-1 to be locked after Sep 3rd (=today()-2) .
Hope to have a solution from this fourmCell Lock.xlsx

Thanks
Rajesh

[Rajesh Kr Joshi]

My apology, I was not aware of this. Certainly I will keep this in mind. Should I reposting this question in the forum? also request you to please help me in setting range etc as I am in a learning phase of macro. Or it will be great if you can put the code in the same sheet and revert.

Thanks
Rajesh

[Admin]

Hi Rajesh,

No need to apologise As I told you, you have to paste the above code in ThisWorkbook module of your workbook.

Hit Alt + F11 > Double click on ThisWorkbook and paste the code there. I have commented the codes where you need to make adjustment. Like Sheet name, range, password etc.. I can't upload the workbook from office. I'll upload the workbook once I returned home.

[Rajesh Kr Joshi]

Thank you. I will wait for the sheet , meanwhile i will also try your instruction

Thanks
Rajesh

[Rajesh Kr Joshi]

Hi Thanks for the file, however when i am opening this file i am getting run time error 1004 and giving me an option to debug , when i clicked on dbug it is highlighting
wksTarget.Cells.Locked = False in the code. sorry to bother you again and again. i wants the lock range C3:P12.

Thanks
Rajesh

[Admin]

Hi Rajesh,

PFA.

[Admin]

Hi Rajesh,

Replace the existing code with the following. Save and close the workbook. Open the workbook again. (The code will run on opening the workbook)

Private Sub Workbook_Open()
    
    Dim wksTarget       As Worksheet
    Dim rngDate         As Range
    Dim rngData         As Range
    Dim c               As Long
    Dim LastRow         As Long
    Dim LastCol         As Long
    
    Const Pwd           As String = "pwd" '<<  adjust to suit
    
    Set wksTarget = ThisWorkbook.Worksheets("Sheet1") '<<  adjust to suit
    
    If Not blnUnlockedAllCells Then
        wksTarget.Protect Password:=Pwd, userinterfaceonly:=True
        wksTarget.Cells.Locked = False
        blnUnlockedAllCells = True
    End If
    
    Set rngData = wksTarget.Range("c2:p12") '<<  adjust to suit. range including the date row
    
    For c = 1 To rngData.Columns.Count
        If CDate(rngData(1, c)) <= Date - 2 Then
            On Error Resume Next
            rngData.Columns(c).SpecialCells(2).Locked = True
            On Error GoTo 0
        End If
    Next
    
End Sub

[Rajesh Kr Joshi]

Thank you this worked great. One more question, what changes should i make if the date range in rows, not in colums.

Thanks a ton
Rajesh