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

 

[Sal Paradise]

Add this to the worksheet module:

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.

 

[Devin]

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.

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

 

[Sal Paradise]

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.

 

[erik.van.geit]

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

 

[kashyap]

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.

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

 

[Devin]

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.

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

 

[RoryA]

The workbook is shared, therefore you cannot change protection properties.

 

[lenze]

Do you mean if the cell in Column "A" is 2 OR more days older than Today's date? If so, use this

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

 

[kashyap]

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.

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?