Lock cells on the basis of date VBA

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

Thanks
Rajesh

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.

Code:

---

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.

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

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

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.

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

Thanks
Rajesh

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

Hi Rajesh,

PFA.

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)

Code:

---

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

---

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

Code:

---

    Dim wksTarget          As Worksheet
    Dim rngDate            As Range
    Dim rngData            As Range
    Dim c                  As Long
    Dim LastRow            As Long
    Dim LastCol            As Long
    Dim blnUnlockedAllCells As Boolean
   
    Const Pwd              As String = "pwd" '<<  adjust to suit
   
    Set wksTarget = ThisWorkbook.Worksheets("Sheet2") '<<  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("B3:L16") '<<  adjust to suit. range including the date row
   
    For c = 1 To rngData.Rows.Count
        If CDate(rngData(c, 1)) <= Date - 2 Then
            On Error Resume Next
            rngData.Rows(c).SpecialCells(2).Locked = True
            On Error GoTo 0
        End If
    Next

---

Thank a lot this is working awesome.Need one more help or rather I should have ask this question in the earlier post- Currently this code is locking only those cells which have data in it (or written something), is it possible to lock all the cell in the given range.

Thnaks
Rajesh

Just remove

Code:

---

.Specialcells(2)

---

Hi Rajesh,

Since your post counts exceed more than 10, you are now able to download the Classic 2003 Excel Menu from here

Hi ,
Experts, Your solution is working fine, I need one more help from you. Attached is the file in which I wants to implement the macro, but I stuck at a point wherein apart from the green cells, by default all the other cells should be locked, because the green cells are the date base cell lock range. But with the current code only those cells are locked which are with the date range and all other cells are unlocked. It will be great If you can add a tweak in the existing code to fulfil the above requirement. And this macro should start automatically with the sheet open. My miss i should have given all the requirement one go :)..thanks for all your assistance.

Thanks
Rajesh

Hi,

You mean like this

Code:

---

Option Explicit
Dim blnUnlockedAllCells As Boolean
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
    Dim blnUnlockedAllCells As Boolean
   
    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("$C$6:$Y$381") '<<  adjust to suit. range including the date Column
   
    For c = 1 To rngData.Rows.Count
        If CDate(rngData(c, 1)) <= Date - 2 Then
            On Error Resume Next
            rngData.Rows(c).Locked = True
            On Error GoTo 0
        End If
    Next
   
End Sub

---

Paste this code in 'ThisWorkbook' module.

Hi, It is working same as the same previous code. The date base cells are getting locked, but all the other cells are still unlocked. To make is easy to understand , i have color coded the cells in the attached sheet. I wants all the gray cells to be locked by default when the sheet opens and the green cells will be locked on date basis.

Thanks
Rajesh

Hi Rajesh,

Try this one.

Code:

---

Option Explicit
Dim blnUnlockedAllCells As Boolean
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
    Dim blnUnlockedAllCells As Boolean
   
    Const Pwd              As String = "pwd" '<<  adjust to suit
   
    Set wksTarget = ThisWorkbook.Worksheets("Sheet1") '<<  adjust to suit
    Set rngData = wksTarget.Range("$C$6:$Y$381") '<<  adjust to suit. range including the date Column
   
    If Not blnUnlockedAllCells Then
        wksTarget.Cells.Locked = True
        rngData.Locked = False
        wksTarget.Protect Password:=Pwd, userinterfaceonly:=True
        blnUnlockedAllCells = True
    End If
   
    For c = 1 To rngData.Rows.Count
        If CDate(rngData(c, 1)) <= Date - 2 Then
            On Error Resume Next
            rngData.Rows(c).Locked = True
            On Error GoTo 0
        End If
    Next
   
End Sub

---

Hi, This works great....Thanks a ton for all your help.:cheers:

Hi Rajesh,

You are welcome :cheers:

Hi, This code is working fine, but when a user open the file its gives a dbug window with error: "Unable to Set the range property of the range class" and when i click dbug it highlights the below line:
wksTarget.Cells.Locked = True

This happend when I added few more sheets and password protect them, but havnt changed anything in the code, because the code should only work for 1 sheet (that is my sheet1). Seems the code is also looking for other sheets, buut i have already mentioned the wkstraget as sheet1.

Thanks
Rajesh

Hi,

Will look this in detail later. In the meantime, add the following line before the debug line.

Code:

---

wksTarget.Unprotect Password:=Pwd

---

Thanks , it worked :)