VBA help - Locking & unlocking on certain times of day

A

Anthony86

Board Regular
Joined
Jan 31, 2018
Messages
68
Office Version
  1. 365
Platform
  1. Windows
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.

VBA Code: 
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

VBA Code: 
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

VBA Code: 
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


VBA Code: 
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


VBA Code: 
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
 
Sort by date Sort by votes
Hi Dave,

Spoke to soon :) Was working in the spreadsheet during the night and I may have overlooked this part. So come midnight, Tuesday night shift locked and Wednesday night unlocked. I need Tuesday night to stay unlocked till the day shift starts.

Is that possible
 
Upvote 0

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
Anthony86 said:
come midnight, Tuesday night shift locked and Wednesday night unlocked. I need Tuesday night to stay unlocked till the day shift starts.
Click to expand...

Hi
I did state when I first posted that its been many years since I had done anything with the OnTime method & now you mention it, seem to recall running in to similar issue when working across a 24 hr timespan.
I will when have a moment try & have a look at the issue or perhaps another here will kindly point out the blindingly obvious part I missed.

Dave
 
Upvote 0
Had a very short play by setting my system time to 23:59 & locked status for Wed night shift did not change.

I can only guess that you may have another timer running?

Try this updated code & see if works for you

VBA Code: 
Sub SetShift(Optional ByVal WhatShift As XLWorkShift)
    Dim wb              As Workbook
    Dim i               As Long
    Dim StartShift      As Boolean
    Dim DayShift        As Variant, NightShift As Variant, WhichShift   As Variant
    Dim NightShiftStart As Date, DayShiftStart As Date, CurrTime        As Date
   
    On Error GoTo myerror
    '-------------------------------------------------------------------------------------------------
    '                               Ver 2 Nov 2024
    '-------------------------------------------------------------------------------------------------
    '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 & """ '"
   
    StartShift = WhatShift = xlStartShift
   
    'apply shift timer
    If WhatShift <> xlCancelShifts Then
       
        Select Case CurrTime
            Case DayShiftStart To NightShiftStart
                'day shift - set nightshift timer
               If Not StartShift Then Application.OnTime EarliestTime:=NightShiftStart, Procedure:=NightShift
                WhichShift = DayShift
            Case Else
                'night shift - set dayshift timer
                If Not StartShift Then Application.OnTime EarliestTime:=DayShiftStart, Procedure:=DayShift
                WhichShift = NightShift
        End Select
        'when workbook first opened, unlock appropriate shift ranges in each weekday sheet
        If StartShift 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

Dave
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Question Question
VBA - Run time error '9': subscript out of range
Replies
3
Views
173
RoryA
RoryA
N
  • Question Question
VBA - Intersect code being re-initiated
Replies
1
Views
187
Peter_SSs
Peter_SSs
J
  • Question Question
Assistance changing VBA code to display as HTML or picture of a selection in Lotus Notes
Replies
2
Views
202
jularobert
J
N
  • Question Question
Locking a row after info entered
Replies
1
Views
755
RustamMika
R
G
  • Question Question
Workbook formulas copied with Sheet references in new Workbook
Replies
0
Views
396
GK039
G

Forum statistics

Threads
1,223,577
Messages
6,173,163
Members
452,503
Latest member
AM74

Share this page

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