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 fourm102

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

[S M C]

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

[Rajesh Kr Joshi]

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

[S M C]

Just remove
.Specialcells(2)

[Admin]

Hi Rajesh,

Since your post counts exceed more than 10, you are now able to download the Classic 2003 Excel Menu from here (http://www.excelfox.com/forum/forumdisplay.php?14-Classic-Menu)

[Rajesh Kr Joshi]

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

[Admin]

Hi,

You mean like this


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.

[Rajesh Kr Joshi]

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

[Admin]

Hi Rajesh,

Try this one.


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

[Rajesh Kr Joshi]

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

[Admin]

Hi Rajesh,

You are welcome :cheers:

[Rajesh Kr Joshi]

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

[Admin]

Hi,

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

wksTarget.Unprotect Password:=Pwd

[Rajesh Kr Joshi]

Thanks , it worked :)