VBA help - Locking & unlocking on certain times of day

[Anthony86]

Hi,

Can anyone shed some light on why this code isn't working. This is code from another site and some that had been sent to me.

What I'm after is some code that locks the worksheets depending on time off day. I currently have a day/night shift and I need only their cells open when they are on shift. The code seems to loop with the timers that are set.

Private Sub Workbook_Open()
Dim CurrTime As Date
Dim LockTime As Date
Dim UnLockTime As Date

CurrTime = Time ' Get the Current Time
LockTime = TimeValue("06:05:00") ' Specify the Lock Time
UnLockTime = TimeValue("18:00:00") ' Specify the Unlock Time

     If CurrTime > UnLockTime Then ' If the sheet is opened later than the specified unlock time then we want make sure the cells are unlocked.

            Application.Run "LockSheet"

     Else

        If CurrTime < LockTime Then ' Check to see if the sheet is opened before the lock time

            ' When the sheet is open, before the LockTime, we need to make sure the cells are unlocked
            Application.Run "LockSheet"

            ' Then we can set a timer to run to lock the cells at the defined time.
            Application.OnTime UnLockTime - CurrTime + Now, "UnLockSheet"

            Else

                ' This will automaticly Lock the cells if opened after the Lock time but before the unlock time
                Application.Run "UnLockSheet"

                ' If opened after the Lock time but before the unlock time, the timer will need to start, ready to unlock the cells at the specified time
                Application.OnTime LockTime - CurrTime + Now, "LockSheet"

        End If

     End If

   
End Sub

Sub LockSheet()
    
    Application.ScreenUpdating = False

    ' This will lock the cells

    ' Specify the exact sheet name otherwise whichever sheet is active, will have cells unlocked and a password set
    ' I would also specify the workbook name to prevent any other workbook cell being locked and sheets being password protected

    Workbooks("Test - Copy.xlsm").Worksheets("Sun").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Sun").Range("A1:Y5").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Sun").Range("A7:Y7").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Sun").Protect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Mon").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Mon").Range("A1:Y5").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Mon").Range("A7:Y7").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Mon").Protect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Tues").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Tues").Range("A1:Y5").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Tues").Range("A7:Y7").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Tues").Protect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Weds").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Weds").Range("A1:Y5").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Weds").Range("A7:Y7").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Weds").Protect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Thurs").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Thurs").Range("A1:Y5").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Thurs").Range("A7:Y7").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Thurs").Protect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Fri").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Fri").Range("A1:Y5").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Fri").Range("A7:Y7").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Fri").Protect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Sat").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Sat").Range("A1:Y5").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Sat").Range("A7:Y7").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Sat").Protect Password:="Password"
    
    
    MsgBox "Day cells have been locked / Nights unlocked"
    
    
    
    ' Now the timer has to be reset to unlock the cells
    Dim CurrTime As Date
    Dim UnLockTime As Date

    CurrTime = Time
    UnLockTime = TimeValue("18:00:00")
    Application.OnTime UnLockTime - CurrTime + Now, "UnLockSheet"

    Application.Run "NightUnLock"
    Application.ScreenUpdating = True
    

End Sub

Sub NightUnLock()

Select Case weekday(Date, vbSunday)
  Case 1 'Sunday
    Workbooks("Test - Copy.xlsm").Worksheets("Sun").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Sun").Range("A6:Y6").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Sun").Range("A8:Y8").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Sun").Protect Password:="Password"
  Case 2 ' Monday
    Workbooks("Test - Copy.xlsm").Worksheets("Mon").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Mon").Range("A6:Y6").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Mon").Range("A8:Y8").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Mon").Protect Password:="Password"
  Case 3  'Tuesday
   Workbooks("Test - Copy.xlsm").Worksheets("Tues").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Tues").Range("A6:Y6").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Tues").Range("A8:Y8").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Tues").Protect Password:="Password"
  Case 4  'Wednesday
    Workbooks("Test - Copy.xlsm").Worksheets("Weds").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Weds").Range("A6:Y6").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Weds").Range("A8:Y8").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Weds").Protect Password:="Password"
  Case 5  'Thursday
    Workbooks("Test - Copy.xlsm").Worksheets("Thurs").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Thurs").Range("A6:Y6").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Thurs").Range("A8:Y8").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Thurs").Protect Password:="Password"
  Case 6  'Friday
    Workbooks("Test - Copy.xlsm").Worksheets("Fri").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Fri").Range("A6:Y6").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Fri").Range("A8:Y8").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Fri").Protect Password:="Password"
  Case 7  'Saturday
    Workbooks("Test - Copy.xlsm").Worksheets("Sat").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Sat").Range("A6:Y6").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Sat").Range("A8:Y8").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Sat").Protect Password:="Password"
    
    ThisWorkbook.Save
  End Select
  
End Sub

Sub UnLockSheet()

    Application.ScreenUpdating = False

    ' This will unlock the cells

    ' Specify the exact sheet name otherwise whichever sheet is active, will have cells unlocked and a password set
    ' I would also specify the workbook name to prevent any other workbook cells being unlocked and sheets being password protected
    Select Case weekday(Date, vbSunday)
  Case 1 'Sunday
    Workbooks("Test - Copy.xlsm").Worksheets("Sun").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Sun").Range("A1:Y5").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Sun").Range("A7:Y7").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Sun").Protect Password:="Password"
  Case 2 ' Monday
    Workbooks("Test - Copy.xlsm").Worksheets("Mon").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Mon").Range("A1:Y5").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Mon").Range("A7:Y7").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Mon").Protect Password:="Password"
  Case 3  'Tuesday
   Workbooks("Test - Copy.xlsm").Worksheets("Tues").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Tues").Range("A1:Y5").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Tues").Range("A7:Y7").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Tues").Protect Password:="Password"
  Case 4  'Wednesday
    Workbooks("Test - Copy.xlsm").Worksheets("Weds").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Weds").Range("A1:Y5").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Weds").Range("A7:Y7").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Weds").Protect Password:="Password"
  Case 5  'Thursday
    Workbooks("Test - Copy.xlsm").Worksheets("Thurs").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Thurs").Range("A1:Y5").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Thurs").Range("A7:Y7").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Thurs").Protect Password:="Password"
  Case 6  'Friday
    Workbooks("Test - Copy.xlsm").Worksheets("Fri").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Fri").Range("A1:Y5").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Fri").Range("A7:Y7").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Fri").Protect Password:="Password"
  Case 7  'Saturday
    Workbooks("Test - Copy.xlsm").Worksheets("Sat").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Sat").Range("A1:Y5").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Sat").Range("A7:Y7").Locked = False
    Workbooks("Test - Copy.xlsm").Worksheets("Sat").Protect Password:="Password"
    
  End Select
  Application.Run "NightLock"
  
  ThisWorkbook.Save

    MsgBox "Days have been unlocked / Nights Locked"
    
End Sub

Sub NightLock()
 
  
    'Nights Lock
    Workbooks("Test - Copy.xlsm").Worksheets("Sun").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Sun").Range("A6:Y6").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Sun").Range("A8:Y8").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Sun").Protect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Mon").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Mon").Range("A6:Y6").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Mon").Range("A8:Y8").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Mon").Protect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Tues").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Tues").Range("A6:Y6").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Tues").Range("A8:Y8").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Tues").Protect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Weds").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Weds").Range("A6:Y6").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Weds").Range("A8:Y8").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Weds").Protect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Thurs").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Thurs").Range("A6:Y6").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Thurs").Range("A8:Y8").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Thurs").Protect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Fri").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Fri").Range("A6:Y6").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Fri").Range("A8:Y8").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Fri").Protect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Sat").Unprotect Password:="Password"
    Workbooks("Test - Copy.xlsm").Worksheets("Sat").Range("A6:Y6").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Sat").Range("A8:Y8").Locked = True
    Workbooks("Test - Copy.xlsm").Worksheets("Sat").Protect Password:="Password"

End Sub

 

[dmt32]

Hi

It’s been many years since I have done anything that uses OnTime function but found a quiet moment to have a look at what I think you are trying to do & hopefully what I have come up with will go in right direction -maybe

Please follow directions carefully

1 – Make a BACK-UP of your workbook & then DELETE ALL existing code

2 – Place Following Codes in STANDARD modules as directed

These codes In module named LockSheet_Code

Enum XLWorkShift
    xlDayShift = 1
    xlNightShift
    xlStartShift
    xlCancelShifts
    xlLockCells
End Enum

Sub LockSheet(ByVal WhatShift As XLWorkShift, ByVal wb As String)
    Dim DayOfWeek       As Variant
    Dim ws              As Worksheet
    Dim LockAllCells    As Boolean
    
    Const strPassword = "Password"
    
    'lock all cells before closing & saving
    LockAllCells = WhatShift = xlLockCells
    
    'day of week array
    DayOfWeek = Application.GetCustomListContents(xlDay)
    
    Application.ScreenUpdating = False
    
    'loop all weekday sheets & apply locked status
    For Each ws In Workbooks(wb).Worksheets(DayOfWeek)
        With ws
            .Unprotect strPassword
            .Range("A1:Y5,A7:Y7").Locked = WhatShift = xlNightShift Or LockAllCells
            .Range("A6:Y6,A8:Y8").Locked = WhatShift = xlDayShift Or LockAllCells
            .Protect strPassword
        End With
    Next ws
    
    If Not LockAllCells Then
        'activate today's sheet
        Worksheets(Format(Date, "ddd")).Activate
        Application.ScreenUpdating = True
        'inform user
        MsgBox IIf(WhatShift = xlDayShift, "Day", "Night") & " Cells have been unlocked", 64, "Information"
        're-set timer
        SetShift
    Else
        'activate sheet 1 & save
        Worksheets(1).Activate
        Workbooks(wb).Save
    End If
    
End Sub

This code In module named SetShift_Code

Sub SetShift(Optional ByVal WhatShift As XLWorkShift)
    Dim wb              As Workbook
    Dim i               As Long
    Dim DayShift        As Variant, NightShift As Variant, WhichShift   As Variant
    Dim NightShiftStart As Date, DayShiftStart As Date, CurrTime        As Date
    
    On Error GoTo myerror
    '-------------------------------------------------------------------------------------------------
    'set object variable to workbook
    
    'not sure if your code resides in the same workbook it applies to or if you are refering to another?
    'if applies to another workbook then use this line ensuring that you have to correct name entered
    Set wb = Workbooks("Test - Copy.xlsm")
    
    'but if code resides in the workbook it applies to then just use this line
    'Set wb = ThisWorkbook
    '------------------------------------------------------------------------------------------------
    '------------------------------------------------------------------------------------------------
    'initialize shift time variables
    CurrTime = Time  'system time
    NightShiftStart = TimeValue("18:00:00")
    DayShiftStart = TimeValue("06:05:00")
    '------------------------------------------------------------------------------------------------
    
    'unlikely to occur but just in case - add 5 seconds to ensure night shift timer applied
    If CurrTime = NightShiftStart Then CurrTime = CurrTime + (5 / 86400)
    
    'intialize shift variables
    NightShift = "'LockSheet """ & xlNightShift & """,""" & wb.Name & """ '"
    DayShift = "'LockSheet """ & xlDayShift & """,""" & wb.Name & """ '"
    LockCells = "'LockSheet """ & xlLockCells & """,""" & wb.Name & """ '"
    
    'apply shift timer
    If WhatShift <> xlCancelShifts Then
        
        Select Case CurrTime
            Case DayShiftStart To NightShiftStart
                'day shift - set nightshift timer
                Application.OnTime EarliestTime:=NightShiftStart, Procedure:=NightShift
                WhichShift = DayShift
            Case Else
                'night shift - set dayshift timer
                Application.OnTime EarliestTime:=DayShiftStart, Procedure:=DayShift
                WhichShift = NightShift
        End Select
        'when workbook first opened, unlock appropriate shift ranges in each weekday sheet
        If WhatShift = xlStartShift Then Application.Run WhichShift
        
    Else
        'cancel timers
        On Error Resume Next
        For i = 1 To 2
            Application.OnTime EarliestTime:=Choose(i, NightShiftStart, DayShiftStart), _
                               Procedure:=Choose(i, NightShift, DayShift), Schedule:=False
        Next i
        On Error GoTo myerror
        'lock all cells in range before saving
        Application.Run LockCells
    End If
    
myerror:
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

These codes In ThisWorkbook Code Page

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    SetShift xlCancelShifts
End Sub

Private Sub Workbook_Open()
    SetShift xlStartShift
End Sub

3 – It is important that your worksheets are named with recognised abbreviated weekday names i.e. Mon, Tue, Wed, Thu, Fri, Sat, Sun

I have only lightly tested solution and hopefully what I have done is correct - when you open then workbook code should change the locked status to the ranges for appropriate shift at specified time it will also set timer for the next shift.

When you close the workbook, timers should be cancelled & workbook saved.

Dave