Lock cells after Today's date passed (VBA excel code)

[rt1306]

I am new to this forum so hello to all.

I am trying to lock cells after today's date has passed so that no one can make changes to it after today's date has lapsed. This is for protective reasons so that people do not remove their names from reserving something after using it. Now the code should disallow locking after cell input entry when today's date hasn't passed so that changes can still be made by the user. I am trying to determine the code to do this but I have no idea as to how to do it.

Here's a scenario: I reserve something for Aprill 11, 2009. I input my name. Since it's April 9th, 2009, I am still able to make changes up and until April 11, 2009. After this date, the cell is locked and no changes can be made, except for the administrator.

Also, a code to allow the administrator to make changes within the cells if need be. That would be appreciated.

Please advise,

Thank you

[royUK]

Will here be other cells containing reservations or just the one?

[Kenneth Hobson]

You need to lock the sheets and only unprotect them in the Open event. Otherwise, they can disable macros and your code would not work.

See this for an example that relates a bit. http://www.vbaexpress.com/forum/showthread.php?t=22918

[rt1306]

Well, there will be cells that contain a reservation name before and after today's date. I want to automatically lock all cells from (D7:J7675) prior to today's date (not including today's date) so that no changes can be made unless you have administrative privileges. This is to protect the integrity of the reservation so that when the reserved thing has been used, the user cannot remove their name to illustrate that they did not use it.

I've attached a sample reservation schedule for reference as to what I mean.

Please Advise,

Thank you

[royUK]

using merged cells makes this more complicated. Try this code in the WorkBook_Open event. Note you must first of all unlock all cells in that range - Format -> Cells -> Protection and de-select Locked

Option Explicit

Private Sub Workbook_Open()
    Const PW   As String = "secret"
    Dim rBookings As Range
    Dim cl     As Range
    Dim mArea  As Range
    With Sheets("Availability")
        .Unprotect PW
        Set rBookings = .Range(.Cells(7, 4), .Cells(7675, 10)).SpecialCells(xlCellTypeConstants)
        For Each cl In rBookings
            Set mArea = .Cells(cl.Row, 1).MergeArea
            If mArea.Cells(1, 1).Value <= Date Then cl.Locked = True
        Next cl
        .Protect PW
    End With
End Sub

Copy the code
Select the workbook in which you want to use the code
Hold the Alt key, and press the F11 key, to open the Visual Basic Editor
In the Project Explorer, find your workbook, and open the list of Microsoft Excel Objects
Right-click on the ThisWorkbook object, and choose View Code
Where the cursor is flashing, choose Edit | Paste

[rt1306]

Hi,

Thank you for the code though there seems to be a run time error '1004

Option Explicit

Private Sub Workbook_Open()
    Const PW   As String = "secret"
    Dim rBookings As Range
    Dim cl     As Range
    Dim mArea  As Range
    With Sheets("Availability")
        .Unprotect PW
Set rBookings = .Range(.Cells(7, 4), .Cells(7675, 10)).SpecialCells(xlCellTypeConstants)
For Each cl In rBookings
            Set mArea = .Cells(cl.Row, 1).MergeArea
            If mArea.Cells(1, 1).Value <= Date Then cl.Locked = True
        Next cl
        .Protect PW
    End With
End Sub

Thank you for the help. Please advise on this error.

[modytrane]

I tried Roy's code with one small change and it seems to work.
see attached file.
modytrane

[royUK]

Your merged cells containing the dates make the task harder.

[royUK]

Change <= to <

The only reason that I can see for the error is if no cells in the range have values. I used Specialcells to reduce the range to check. Try this amended code

Option Explicit

Private Sub Workbook_Open()
    Const PW   As String = "secret"
    Dim rBookings As Range
    Dim cl     As Range
    Dim mArea  As Range
    With Sheets("Availability")
        .Unprotect PW
'if no cells have entries in the range the code will error
'the exit handler skips to the point where the password is reset
        On Error GoTo exithandler
        Set rBookings = .Range(.Cells(7, 4), .Cells(7675, 10)).SpecialCells(xlCellTypeConstants)
        MsgBox rBookings.Address
        For Each cl In rBookings
            Set mArea = .Cells(cl.Row, 1).MergeArea
            If mArea.Cells(1, 1).Value < Date Then cl.Locked = True
        Next cl
exithandler:
        .Protect PW
    End With
End Sub

[rt1306]

Hi RoyUK, how do I mark it as solved?

[royUK]

Hi RoyUK, how do I mark it as solved?

You cannot if the first post was more than two days ago. I'll do it for you.

Did you try the amended code above?

[rt1306]

I did amend the code. Thank you RoyUK.

[rt1306]

Help
The code didn't lock yesterday's date. It's still unlocked...All other cells from April 13 and prior are locked but April 14 is not. Can someone help make changes?

I've attached a new spreadsheet with the current code in it.

Thank you

[royUK]

If you want to lock all the cells then remove the specialcells

Option Explicit

Private Sub Workbook_Open()
    Const PW   As String = "secret"
    Dim rBookings As Range
    Dim cl     As Range
    Dim mArea  As Range
    With Sheets("Availability")
        .Unprotect PW
        'if no cells have entries in the range the code will error
        'the exit handler skips to the point where the password is reset
        On Error GoTo exithandler
        Set rBookings = .Range(.Cells(7, 4), .Cells(7675, 10))
        For Each cl In rBookings
            Set mArea = .Cells(cl.Row, 1).MergeArea
            If mArea.Cells(1, 1).Value < Date Then cl.Locked = True
        Next cl
exithandler:
        .Protect PW
    End With
End Sub

[royUK]

The sheet needs to be protected to allow cells to be Locked. As a result user actions are restricted.

To edit locked cells simply use the password to unprotect the sheet

[Kenneth Hobson]

Set your computer date by the calendar in the system tray to test.

[rt1306]

Can there not be an extra code to enable all functions from today's date and later?

Btw, thanks for the suggestion Kenneth. Nice mini test. Though it still didn't lock all the cells prior to today's date.

[robrobet]

How I can set VBA to my active worksheet only print if Cell L41 have today date, I have 31 sheet in my workbook so only active work sheet print if date is correct.

Thanks

[HaHoBe]

Hi, robrobet,

Welcome to the Forum.

Unfortunately your post does not comply with Rule 2 of our Forum RULES. Do not post a question in the thread of another member -- start your own thread.

If you feel an existing thread is particularly relevant to your need, provide a link to the other thread in your new thread.

Old threads are often only monitored by the original participants. New threads not only open you up to all possible participants again, they typically get faster response, too.

Ciao,
Holger

[robrobet]

yes I got it , Thanks to correct me .