Lock range if date < today

[Kashyap]

Hi I need to lock cells in protected and shared workbook if cell value in
colA is 2 days less than today

Eg. if A5=today()-2 then it should lock range A5:I5

 

[Mike Fogleman]

Try this snippet:

Sub DateLock()
Dim varDate As Date
Dim dif As Long
varDate = Range("A5")
If DateDiff("d", varDate, Date) > 1 Then
Range("A5:I5").Locked = True
ActiveSheet.Protect
Else
Exit Sub
End If
End Sub

Mike F

 

[Kashyap]

It is not just 1 particular row.. How to do that?

 

[Mike Fogleman]

This will loop down column A and check the dates. It assumes your data
starts on row 2, if it does not then adjust ARng to start on the proper row.

Sub DateLock()
Dim varDate As Date
Dim dif As Long, LRow As Long
Dim ARng As Range, c As Range

LRow = Cells(Rows.Count, 1).End(xlUp).Row
Set ARng = Range("A2:A" & LRow) 'assumes row 1 is headers
For Each c In ARng
varDate = Range("A" & c.Row)
If DateDiff("d", varDate, Date) > 1 Then
ActiveSheet.Unprotect
Range("A" & c.Row & ":I" & c.Row).Locked = True
Else
'do nothing
End If
Next
ActiveSheet.Protect
End Sub

Mike F

 

[Kashyap]

Getting type mismatch error

This will loop down column A and check the dates. It assumes your data
starts on row 2, if it does not then adjust ARng to start on the proper row.

Sub DateLock()
Dim varDate As Date
Dim dif As Long, LRow As Long
Dim ARng As Range, c As Range

LRow = Cells(Rows.Count, 1).End(xlUp).Row
Set ARng = Range("A2:A" & LRow) 'assumes row 1 is headers
For Each c In ARng
varDate = Range("A" & c.Row)
If DateDiff("d", varDate, Date) > 1 Then
ActiveSheet.Unprotect
Range("A" & c.Row & ":I" & c.Row).Locked = True
Else
'do nothing
End If
Next
ActiveSheet.Protect
End Sub

Mike F

 

[Kashyap]

It is working fine in unshared workbook..

how to do with shared?

 

[Gord Dibben]

Your type mismatch could arise from the fact that one or more of the data
is/are not a date?

This won't run on a Shared workbook in any case.

You cannot protect and unprotect sheets in a shared book.

Whatever protection is on at time of sharing cannot be changed without
un-sharing.

Check out help on Features that are unavailable in shared workbooks


Gord Dibben MS Excel MVP