Lock range if date < today

kashyap

Board Regular
Joined
Mar 28, 2009
Messages
173
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
 

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
Add this to the worksheet module:

Code:
Dim varOldValue As Variant

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("B1:I20")) Is Nothing Then
        If Cells(Target.Row, 1).Value = Application.Evaluate("=TODAY()-2") Then
            Target.Formula = varOldValue
        End If
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    varOldValue = Target.Formula
End Sub

If the value in column A equals TODAY()-2, then you can't change the value. Otherwise you can.
 
Upvote 0
Put this in your module and run it. It will do the job for cells A1:A100 and go out to column I on the cells that need to be locked.

PHP:
Sub LockCells()
    Application.ScreenUpdating = False
    For i = 1 To 100
    If Range("A" & i) + 3 > Date Then Range("A" & i & ":I" & i).Locked = True
    Next i
    Application.ScreenUpdating = True
End Sub
 
Last edited:
Upvote 0
Or alternatively you could do a find for TODAY()-2, offset by (0,1), resize by (1,8) and then lock, which wouldn't require looping through all cells.
 
Upvote 0
Hi, try this

Validate the cells like this:
select A5:E...
Data / Validation
choose "custom"
formula:
=$A5>=TODAY()-2

This will not stop from deleting the contents though.

kind regards,
Erik
 
Upvote 0
Put this in your module and run it. It will do the job for cells A1:A100 and go out to column I on the cells that need to be locked.

PHP:
Sub LockCells()
    Application.ScreenUpdating = False
    For i = 1 To 100
    If Range("A" & i) + 3 > Date Then Range("A" & i & ":I" & i).Locked = True
    Next i
    Application.ScreenUpdating = True
End Sub


I tried above, but getting 'type mismatch' error
 
Upvote 0
A mismatch error will occur if you have something other than a date in the cells the macro is testing for the date condition. Its an easy fix, just use the code below and it will skip over the errors.

HTML:
Sub LockCells()
    Application.ScreenUpdating = False
    On Error Resume Next
    For i = 1 To 100
    If Range("A" & i) + 3 > Date Then Range("A" & i & ":I" & i).Locked = True
    Next i
    On Error GoTo 0
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
The workbook is shared, therefore you cannot change protection properties.
 
Upvote 0
Do you mean if the cell in Column "A" is 2 OR more days older than Today's date? If so, use this
Code:
Private Sub Workbook_Open()
Dim cl As Range
Sheet1.Unprotect "password"
For Each cl In Sheet1.Range("$A$2:$A" & Range("$A$65536").End(xlUp).Row)
If cl < Date - 2 Then
    Range(Cells(cl.Row, 1), Cells(cl.Row, 8)).Locked = True
End If
Next cl
Sheet1.Protect "password"
End Sub
In the ThisWorkBook module
lenze
 
Upvote 0
A mismatch error will occur if you have something other than a date in the cells the macro is testing for the date condition. Its an easy fix, just use the code below and it will skip over the errors.

HTML:
Sub LockCells()
    Application.ScreenUpdating = False
    On Error Resume Next
    For i = 1 To 100
    If Range("A" & i) + 3 > Date Then Range("A" & i & ":I" & i).Locked = True
    Next i
    On Error GoTo 0
    Application.ScreenUpdating = True
End Sub

Now its doing nothing.. Am I wrong somewhere?
 
Upvote 0

Forum statistics

Threads
1,224,559
Messages
6,179,513
Members
452,921
Latest member
BBQKING

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top