Assign Expiry Date(Time-Lock) to Excel Workbook

N

nabeelahmed

Board Regular
Joined
Jun 19, 2020
Messages
76
Office Version
  1. 365
Platform
  1. Windows
Dear Friends,

Can somebody help me for subject topic, How can we add expiry date (Time-Lock) to a Excel workbook so that after that date Workbook gets lock and required password to re-validate/Unlock ???

Regards,
 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
Sort by date Sort by votes
Yes sure you can. Because you will be storing a password in VBA, a knowledgeable person will be able to circumvent the system.
Also people who disable macro's on startup could open the workbook.

You can protect yourself against most of this, but it will complicate things. Below is the simple route.

The way to do this is through the WorkBook_Open event. Here you can check the current date against the lock date set either in a workbook cell, or in the macro itself (the first option is easier maintenance and makes the macro easily reusable).

The logic would be:
On Open workbook:
  1. check date against stored date
  2. If younger then unlock worksheet(s)
  3. If older, lock workbook and ask user to unlock
On Save workbook:
  1. Lock all sheets
  2. Save workbook
  3. Unlock all sheets

Let me know if you need help on this
 
Upvote 0
sijpie said:
Yes sure you can. Because you will be storing a password in VBA, a knowledgeable person will be able to circumvent the system.
Also people who disable macro's on startup could open the workbook.

You can protect yourself against most of this, but it will complicate things. Below is the simple route.

The way to do this is through the WorkBook_Open event. Here you can check the current date against the lock date set either in a workbook cell, or in the macro itself (the first option is easier maintenance and makes the macro easily reusable).

The logic would be:
On Open workbook:
  1. check date against stored date
  2. If younger then unlock worksheet(s)
  3. If older, lock workbook and ask user to unlock
On Save workbook:
  1. Lock all sheets
  2. Save workbook
  3. Unlock all sheets

Let me know if you need help on this
Click to expand...
Can you help me on that??
 
Upvote 0
Just to make sure what you mean by locking the workbook:
  1. Lock the workbook, so that password is needed to open and view the sheets, or
  2. Lock the sheets, so that users can view them, but can't make any changes
Let me know
 
Upvote 0
sijpie said:
Just to make sure what you mean by locking the workbook:
  1. Lock the workbook, so that password is needed to open and view the sheets, or
  2. Lock the sheets, so that users can view them, but can't make any changes
Let me know
Click to expand...
Hi option 2.. After fixed/set date sheet should get lock and user could view the data only and password is required to validate the sheets..
 
Upvote 0
Hi Ahmed,

It took some time, because of other things, and I wanted to make the code pretty good. Remember, it is not totally secure: someone with sufficient knowledge can get to the code and find the unlock password. But it is not easy.

There are two sets of code. This first set of code is entered into a normal module.
  1. Open the workbook where you want to apply this.
  2. Save-As a .xlsm workbook (macro enabled)
  3. Press Alt-F11 to open the VBA editor (VBE).
  4. In the top left hand window of the VBE you will see your workbook and its sheets.
  5. Right-click on the workbook and select: Insert... / Module
  6. A white window will appear on the right.
  7. Copy/ paste the following code in that window
VBA Code: 
Option Explicit

Public Const sHDName = "ProtectSupport", sLDName = "LockDate", sWBLName = "WBLocked"
Public Const sPW = "MyPW"      '<<<<< Change to suit your password

Dim bReset As Boolean

Sub FirstTimeSetup()
'Macro call by Workbook_Open to set and store the lock date
'This is stored in a sheet which will be hidden
    Dim wsWS As Worksheet
    
    Application.ScreenUpdating = False
    On Error Resume Next
    Set wsWS = Sheets(sHDName)
    On Error GoTo 0
    If wsWS Is Nothing Then      'sheet does not exist, create
        With ThisWorkbook
            Set wsWS = .Sheets.Add(after:=.Sheets(.Sheets.Count))
            wsWS.Name = sHDName
            .Names.Add Name:=sLDName, RefersTo:=wsWS.Range("A2")
            .Names.Add Name:=sWBLName, RefersTo:=wsWS.Range("A5")
        End With
        With Range(sLDName)
            .Offset(-1, 0) = sLDName
            .Value = GetDate
            .Offset(2, 0) = sWBLName
        End With
        wsWS.Visible = xlSheetVeryHidden 'Sheet is not visible in the sheet list, only in VBA
    End If
    If bReset Then
        With Range(sLDName)
            .Value = GetDate
        End With
    End If
    Application.ScreenUpdating = True
    
End Sub

Function GetDate() As Date
'Get the lock date
    Dim vD As Variant
    
    Do
        vD = InputBox(prompt:="Please enter date after which the sheets in" & vbCrLf & _
                            "this workbook need to be locked." & vbCrLf & _
                            "Enter as " & Format(Date, "Short Date") & ".", _
                      Title:="Workbook lock date required")
    Loop While Not IsDate(vD)
    GetDate = CDate(vD)
End Function

Sub LockSheets(sPWd As String)
'Called by Workbook_Open. Locks all sheets
    Dim wsWS As Worksheet
    
    'first unlock all sheets as we will be changing the lock status of cells
    UnlockSheets sPWd
    'then on each sheet (not on our support sheet) lock all cells and protect
    For Each wsWS In ThisWorkbook.Worksheets
        If wsWS.Name <> sHDName Then
            wsWS.Cells.Locked = True
            wsWS.Protect sPWd, AllowSorting:=True, AllowFiltering:=True
        End If
    Next wsWS
End Sub
Sub UnlockSheets(sPWd As String)
'Unlocks all sheets. Sets all cells to editable!
    Dim wsWS As Worksheet
    
    For Each wsWS In ThisWorkbook.Worksheets
        wsWS.Unprotect sPWd
    Next wsWS
    
End Sub

Sub SetWB2Locked(sPWd As String)
    Range(sWBLName) = True  'to mark that this process has been carried out
    LockSheets sPWd
    MsgBox prompt:="The sheets in this workbook have just been locked as the expiry date has passed.", _
           Title:="Sheets locked"

End Sub
Sub ResetLockDate()
'Allows authorised user to change the lock date
    Dim vP
    Dim dDt As Date
    Dim sMsg As String
    
    vP = InputBox(prompt:="Please enter password to change the lockdate for this workbook", _
                Title:="Password required")
    If vP = sPW Then
        dDt = GetDate
        If dDt <= Date And Date > Range(sLDName) Then
            MsgBox "Date provided does not make sense: the workbook is already locked. No action taken."
        Else
            Range(sLDName) = dDt
            If Range(sWBLName) Then
                UnlockSheets sPW
                Range(sWBLName) = False
                sMsg = "All worksheets have been unlocked. " & vbCrLf
            End If
            MsgBox sMsg & "Lock date set to: " & Format(dDt, "short date")
        End If
    Else
        MsgBox "Incorrect or no password given. No action taken"
    End If
End Sub

Private Sub UL()
    UnlockSheets sPW
End Sub
  1. Look at the top of the code. There is a green comment starting with: <<<<
  2. This is on the row where the lock password is fixed. Change the MyPW to the password that you are or will be using to lock sheets
  3. Store the password somewhere safe
  4. Now next double click on the ThisWorkbook in the top left hand window under your workbook
  5. This will open a new white window on the right.
  6. Copy/ paste the following code in that window
VBA Code: 
Option Explicit

    Dim vWS

Private Sub Workbook_AfterSave(ByVal Success As Boolean)
'Restore any sheets to unlocked, in case user had unlocked these
    Dim iC As Integer
    
    If Range(sWBLName) = False Then Exit Sub ' Workbook has not been locked, no action required
    'else
    For iC = 1 To Me.Worksheets.Count
        If vWS(iC) = False Then            'check the original protect status of each sheet
            Worksheets(iC).Unprotect sPW    'unprotect the sheet, the user had unprotected earlier
            Me.Saved = True                 'tell Excel the workbook has been saved
        End If
    Next iC

End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Set all the sheets to locked before saving, if the lock date has passed.
'This in case an authorised user has unlocked a sheet and saves the workbook
    Dim iC As Integer
    
    If Range(sWBLName) = False Then Exit Sub ' Workbook has not been locked, no action required
    'else
    ReDim vWS(1 To Me.Worksheets.Count)
    For iC = 1 To Me.Worksheets.Count
        vWS(iC) = Worksheets(iC).ProtectContents    'store the status of protection for each sheet
        Worksheets(iC).Protect sPW, AllowSorting:=True, AllowFiltering:=True
    Next iC
End Sub

Private Sub Workbook_Open()
' Runs every time the workbook is opened.     
    FirstTimeSetup
    If Range(sWBLName) = True Then Exit Sub ' Workbook has been locked previously, user has unlocked
        
    'Workbook not locked, check if needs locking
    If Date < Range(sLDName) Then Exit Sub  ' Lockdate has not passed, allow user to use workbook
    
    'Workbook needs to be locked, first time
    SetWB2Locked sPW
End Sub
  • Now go back to Excel (Alt-Tab) and save the workbook.
  • Once you have read the explanation below, go ahead: close the workbook and reopen it

What does the code do? A lot is explained in the comments (green lines) in the code itself
  • The first time you open the workbook it will ask you for a date when the book needs to be locked
  • It wil create a very hidden sheet and store some parameters in there: the lock date and if the sheet is locked
  • Until the lock date has arrived nothing else will happen
  • When the date has arrived, on opening the workbook all the sheets will be locked
  • The user will be told about this (only the first time)
  • A user knowing the password can unlock sheets in the normal manner
  • Such a user can also reset the lock date to a new date, say in a months time.
  • To do this open the macro dialog box, by pressing Alt-F8.
  • Select the ResetLockdate macro and run it.
  • If a user with the password were to unlock sheets and make changes, then when saving the file the saved file will have all sheets locked again to make it secure.
 
Upvote 0
sijpie said:
Hi Ahmed,

It took some time, because of other things, and I wanted to make the code pretty good. Remember, it is not totally secure: someone with sufficient knowledge can get to the code and find the unlock password. But it is not easy.

There are two sets of code. This first set of code is entered into a normal module.
  1. Open the workbook where you want to apply this.
  2. Save-As a .xlsm workbook (macro enabled)
  3. Press Alt-F11 to open the VBA editor (VBE).
  4. In the top left hand window of the VBE you will see your workbook and its sheets.
  5. Right-click on the workbook and select: Insert... / Module
  6. A white window will appear on the right.
  7. Copy/ paste the following code in that window
VBA Code: 
Option Explicit

Public Const sHDName = "ProtectSupport", sLDName = "LockDate", sWBLName = "WBLocked"
Public Const sPW = "MyPW"      '<<<<< Change to suit your password

Dim bReset As Boolean

Sub FirstTimeSetup()
'Macro call by Workbook_Open to set and store the lock date
'This is stored in a sheet which will be hidden
    Dim wsWS As Worksheet
   
    Application.ScreenUpdating = False
    On Error Resume Next
    Set wsWS = Sheets(sHDName)
    On Error GoTo 0
    If wsWS Is Nothing Then      'sheet does not exist, create
        With ThisWorkbook
            Set wsWS = .Sheets.Add(after:=.Sheets(.Sheets.Count))
            wsWS.Name = sHDName
            .Names.Add Name:=sLDName, RefersTo:=wsWS.Range("A2")
            .Names.Add Name:=sWBLName, RefersTo:=wsWS.Range("A5")
        End With
        With Range(sLDName)
            .Offset(-1, 0) = sLDName
            .Value = GetDate
            .Offset(2, 0) = sWBLName
        End With
        wsWS.Visible = xlSheetVeryHidden 'Sheet is not visible in the sheet list, only in VBA
    End If
    If bReset Then
        With Range(sLDName)
            .Value = GetDate
        End With
    End If
    Application.ScreenUpdating = True
   
End Sub

Function GetDate() As Date
'Get the lock date
    Dim vD As Variant
   
    Do
        vD = InputBox(prompt:="Please enter date after which the sheets in" & vbCrLf & _
                            "this workbook need to be locked." & vbCrLf & _
                            "Enter as " & Format(Date, "Short Date") & ".", _
                      Title:="Workbook lock date required")
    Loop While Not IsDate(vD)
    GetDate = CDate(vD)
End Function

Sub LockSheets(sPWd As String)
'Called by Workbook_Open. Locks all sheets
    Dim wsWS As Worksheet
   
    'first unlock all sheets as we will be changing the lock status of cells
    UnlockSheets sPWd
    'then on each sheet (not on our support sheet) lock all cells and protect
    For Each wsWS In ThisWorkbook.Worksheets
        If wsWS.Name <> sHDName Then
            wsWS.Cells.Locked = True
            wsWS.Protect sPWd, AllowSorting:=True, AllowFiltering:=True
        End If
    Next wsWS
End Sub
Sub UnlockSheets(sPWd As String)
'Unlocks all sheets. Sets all cells to editable!
    Dim wsWS As Worksheet
   
    For Each wsWS In ThisWorkbook.Worksheets
        wsWS.Unprotect sPWd
    Next wsWS
   
End Sub

Sub SetWB2Locked(sPWd As String)
    Range(sWBLName) = True  'to mark that this process has been carried out
    LockSheets sPWd
    MsgBox prompt:="The sheets in this workbook have just been locked as the expiry date has passed.", _
           Title:="Sheets locked"

End Sub
Sub ResetLockDate()
'Allows authorised user to change the lock date
    Dim vP
    Dim dDt As Date
    Dim sMsg As String
   
    vP = InputBox(prompt:="Please enter password to change the lockdate for this workbook", _
                Title:="Password required")
    If vP = sPW Then
        dDt = GetDate
        If dDt <= Date And Date > Range(sLDName) Then
            MsgBox "Date provided does not make sense: the workbook is already locked. No action taken."
        Else
            Range(sLDName) = dDt
            If Range(sWBLName) Then
                UnlockSheets sPW
                Range(sWBLName) = False
                sMsg = "All worksheets have been unlocked. " & vbCrLf
            End If
            MsgBox sMsg & "Lock date set to: " & Format(dDt, "short date")
        End If
    Else
        MsgBox "Incorrect or no password given. No action taken"
    End If
End Sub

Private Sub UL()
    UnlockSheets sPW
End Sub
  1. Look at the top of the code. There is a green comment starting with: <<<<
  2. This is on the row where the lock password is fixed. Change the MyPW to the password that you are or will be using to lock sheets
  3. Store the password somewhere safe
  4. Now next double click on the ThisWorkbook in the top left hand window under your workbook
  5. This will open a new white window on the right.
  6. Copy/ paste the following code in that window
VBA Code: 
Option Explicit

    Dim vWS

Private Sub Workbook_AfterSave(ByVal Success As Boolean)
'Restore any sheets to unlocked, in case user had unlocked these
    Dim iC As Integer
   
    If Range(sWBLName) = False Then Exit Sub ' Workbook has not been locked, no action required
    'else
    For iC = 1 To Me.Worksheets.Count
        If vWS(iC) = False Then            'check the original protect status of each sheet
            Worksheets(iC).Unprotect sPW    'unprotect the sheet, the user had unprotected earlier
            Me.Saved = True                 'tell Excel the workbook has been saved
        End If
    Next iC

End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Set all the sheets to locked before saving, if the lock date has passed.
'This in case an authorised user has unlocked a sheet and saves the workbook
    Dim iC As Integer
   
    If Range(sWBLName) = False Then Exit Sub ' Workbook has not been locked, no action required
    'else
    ReDim vWS(1 To Me.Worksheets.Count)
    For iC = 1 To Me.Worksheets.Count
        vWS(iC) = Worksheets(iC).ProtectContents    'store the status of protection for each sheet
        Worksheets(iC).Protect sPW, AllowSorting:=True, AllowFiltering:=True
    Next iC
End Sub

Private Sub Workbook_Open()
' Runs every time the workbook is opened.    
    FirstTimeSetup
    If Range(sWBLName) = True Then Exit Sub ' Workbook has been locked previously, user has unlocked
       
    'Workbook not locked, check if needs locking
    If Date < Range(sLDName) Then Exit Sub  ' Lockdate has not passed, allow user to use workbook
   
    'Workbook needs to be locked, first time
    SetWB2Locked sPW
End Sub
  • Now go back to Excel (Alt-Tab) and save the workbook.
  • Once you have read the explanation below, go ahead: close the workbook and reopen it

What does the code do? A lot is explained in the comments (green lines) in the code itself
  • The first time you open the workbook it will ask you for a date when the book needs to be locked
  • It wil create a very hidden sheet and store some parameters in there: the lock date and if the sheet is locked
  • Until the lock date has arrived nothing else will happen
  • When the date has arrived, on opening the workbook all the sheets will be locked
  • The user will be told about this (only the first time)
  • A user knowing the password can unlock sheets in the normal manner
  • Such a user can also reset the lock date to a new date, say in a months time.
  • To do this open the macro dialog box, by pressing Alt-F8.
  • Select the ResetLockdate macro and run it.
  • If a user with the password were to unlock sheets and make changes, then when saving the file the saved file will have all sheets locked again to make it secure.
Click to expand...

Hi Sijpie,

Thank you very much for your working. I tried these codes when i save after pasting codes i am getting below Run-time error..


1600142645443.png


1600142586418.png


If i Debug Above error and continue then after entering lock date workbook is getting locked but when i am trying to change the lock date the below Run-time error is showing....
and please let me know after worksheet get lock and i wanted to change the lock date then how can i change lock date without entering VBA editor?

Please guide on it....

1600142217834.png

1600142296118.png
 
Upvote 0
Adding one thing more if we lock the sheet anybody is enable to copy the data from the sheets.. Can we restrict on copying the data as well?
 
Upvote 0
This code into the normal module:
VBA Code: 
Option Explicit

Public Const sHDName = "ProtectSupport", sLDName = "LockDate", sWBLName = "WBLocked"
Public Const sPW = "MyPW"      '<<<<< Change to suit your password

Dim bReset As Boolean

Sub FirstTimeSetup()
'Macro call by Workbook_Open to set and store the lock date
'This is stored in a sheet which will be hidden
    Dim wsWS As Worksheet
    
    Application.ScreenUpdating = False
    On Error Resume Next
    Set wsWS = Sheets(sHDName)
    On Error GoTo 0
    If wsWS Is Nothing Then      'sheet does not exist, create
        With ThisWorkbook
            Set wsWS = .Sheets.Add(after:=.Sheets(.Sheets.Count))
            wsWS.Name = sHDName
            .Names.Add Name:=sLDName, RefersTo:=wsWS.Range("A2")
            .Names.Add Name:=sWBLName, RefersTo:=wsWS.Range("A5")
        End With
        With Range(sLDName)
            .Offset(-1, 0) = sLDName
            .Value = GetDate
            .Offset(2, 0) = sWBLName
        End With
        wsWS.Visible = xlSheetVeryHidden 'Sheet is not visible in the sheet list, only in VBA
    End If
    If bReset Then
        With Range(sLDName)
            .Value = GetDate
        End With
    End If
    Application.ScreenUpdating = True
    
End Sub

Function GetDate() As Date
'Get the lock date
    Dim vD As Variant
    
    Do
        vD = InputBox(prompt:="Please enter date after which the sheets in" & vbCrLf & _
                            "this workbook need to be locked." & vbCrLf & _
                            "Enter as " & Format(Date, "Short Date") & ".", _
                      Title:="Workbook lock date required")
    Loop While Not IsDate(vD)
    GetDate = CDate(vD)
End Function

Sub LockSheets(sPWd As String)
'Called by Workbook_Open. Locks all sheets
    Dim wsWS As Worksheet
    
    'first unlock all sheets as we will be changing the lock status of cells
    UnlockSheets sPWd
    'then on each sheet (not on our support sheet) lock all cells and protect
    For Each wsWS In ThisWorkbook.Worksheets
        If wsWS.Name <> sHDName Then
            wsWS.Cells.Locked = True
            wsWS.Protect sPWd, DrawingObjects:=True, Contents:=True, Scenarios:=True, _
                 AllowSorting:=True, AllowFiltering:=True
            wsWS.EnableSelection = xlUnlockedCells
        End If
    Next wsWS
End Sub
Sub UnlockSheets(sPWd As String)
'Unlocks all sheets. Sets all cells to editable!
    Dim wsWS As Worksheet
    
    For Each wsWS In ThisWorkbook.Worksheets
        wsWS.Unprotect sPWd
    Next wsWS
    
End Sub

Sub SetWB2Locked(sPWd As String)
    Range(sWBLName) = True  'to mark that this process has been carried out
    LockSheets sPWd
    MsgBox prompt:="The sheets in this workbook have just been locked as the expiry date has passed.", _
           Title:="Sheets locked"

End Sub
Sub ResetLockDate()
'Allows authorised user to change the lock date
    Dim vP
    Dim dDt As Date
    Dim sMsg As String
    
    vP = InputBox(prompt:="Please enter password to change the lockdate for this workbook", _
                Title:="Password required")
    If vP = sPW Then
        dDt = GetDate
        If dDt <= Date And Date > Range(sLDName) Then
            MsgBox "Date provided does not make sense: the workbook is already locked. No action taken."
        Else
            Range(sLDName) = dDt
            If Range(sWBLName) Then
                UnlockSheets sPW
                Range(sWBLName) = False
                sMsg = "All worksheets have been unlocked. " & vbCrLf
            End If
            MsgBox sMsg & "Lock date set to: " & Format(dDt, "short date")
        End If
    Else
        MsgBox "Incorrect or no password given. No action taken"
    End If
End Sub

and this code into the workbook module:
VBA Code: 
Option Explicit

    Dim vWS

Private Sub Workbook_AfterSave(ByVal Success As Boolean)
'Restore any sheets to unlocked, in case user had unlocked these
    Dim iC As Integer
    
    If Not IsArray(vWS) Then Exit Sub  ' Workbook has not been locked, no action required
    'else
    For iC = 1 To Me.Worksheets.Count
        If vWS(iC) = False Then            'check the original protect status of each sheet
            Worksheets(iC).Unprotect sPW    'unprotect the sheet, the user had unprotected earlier
            Me.Saved = True                 'tell Excel the workbook has been saved
        End If
    Next iC

End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Set all the sheets to locked before saving, if the lock date has passed.
'This in case an authorised user has unlocked a sheet and saves the workbook
    Dim iC As Integer
    Dim wsHS As Worksheet
    
    'to enable saving workbook first time before running the code, need to check if _
     sheet ProtectSupport exists. If not skip the rest.
    On Error Resume Next
    Set wsHS = Sheets(sHDName)
    On Error GoTo 0
    If wsHS Is Nothing Then Exit Sub
    
    
    If Range(sWBLName) = False Then Exit Sub ' Workbook has not been locked, no action required
    'else
    'sometimes hidden sheet gets locked. Unlock
    wsHS.Unprotect sPW
    
    ReDim vWS(1 To Me.Worksheets.Count)
    For iC = 1 To Me.Worksheets.Count
        vWS(iC) = Worksheets(iC).ProtectContents    'store the status of protection for each sheet
        Worksheets(iC).Protect sPW, AllowSorting:=True, AllowFiltering:=True
    Next iC
End Sub

Private Sub Workbook_Open()
    
    FirstTimeSetup
    If Range(sWBLName) = True Then Exit Sub ' Workbook has been locked previously, user has unlocked
        
    'Workbook not locked, check if needs locking
    If Date < Range(sLDName) Then Exit Sub  ' Lockdate has not passed, allow user to use workbook
    
    'Workbook needs to be locked, first time
    SetWB2Locked sPW
End Sub
 
Upvote 0
sijpie said:
This code into the normal module:
VBA Code: 
Option Explicit

Public Const sHDName = "ProtectSupport", sLDName = "LockDate", sWBLName = "WBLocked"
Public Const sPW = "MyPW"      '<<<<< Change to suit your password

Dim bReset As Boolean

Sub FirstTimeSetup()
'Macro call by Workbook_Open to set and store the lock date
'This is stored in a sheet which will be hidden
    Dim wsWS As Worksheet
   
    Application.ScreenUpdating = False
    On Error Resume Next
    Set wsWS = Sheets(sHDName)
    On Error GoTo 0
    If wsWS Is Nothing Then      'sheet does not exist, create
        With ThisWorkbook
            Set wsWS = .Sheets.Add(after:=.Sheets(.Sheets.Count))
            wsWS.Name = sHDName
            .Names.Add Name:=sLDName, RefersTo:=wsWS.Range("A2")
            .Names.Add Name:=sWBLName, RefersTo:=wsWS.Range("A5")
        End With
        With Range(sLDName)
            .Offset(-1, 0) = sLDName
            .Value = GetDate
            .Offset(2, 0) = sWBLName
        End With
        wsWS.Visible = xlSheetVeryHidden 'Sheet is not visible in the sheet list, only in VBA
    End If
    If bReset Then
        With Range(sLDName)
            .Value = GetDate
        End With
    End If
    Application.ScreenUpdating = True
   
End Sub

Function GetDate() As Date
'Get the lock date
    Dim vD As Variant
   
    Do
        vD = InputBox(prompt:="Please enter date after which the sheets in" & vbCrLf & _
                            "this workbook need to be locked." & vbCrLf & _
                            "Enter as " & Format(Date, "Short Date") & ".", _
                      Title:="Workbook lock date required")
    Loop While Not IsDate(vD)
    GetDate = CDate(vD)
End Function

Sub LockSheets(sPWd As String)
'Called by Workbook_Open. Locks all sheets
    Dim wsWS As Worksheet
   
    'first unlock all sheets as we will be changing the lock status of cells
    UnlockSheets sPWd
    'then on each sheet (not on our support sheet) lock all cells and protect
    For Each wsWS In ThisWorkbook.Worksheets
        If wsWS.Name <> sHDName Then
            wsWS.Cells.Locked = True
            wsWS.Protect sPWd, DrawingObjects:=True, Contents:=True, Scenarios:=True, _
                 AllowSorting:=True, AllowFiltering:=True
            wsWS.EnableSelection = xlUnlockedCells
        End If
    Next wsWS
End Sub
Sub UnlockSheets(sPWd As String)
'Unlocks all sheets. Sets all cells to editable!
    Dim wsWS As Worksheet
   
    For Each wsWS In ThisWorkbook.Worksheets
        wsWS.Unprotect sPWd
    Next wsWS
   
End Sub

Sub SetWB2Locked(sPWd As String)
    Range(sWBLName) = True  'to mark that this process has been carried out
    LockSheets sPWd
    MsgBox prompt:="The sheets in this workbook have just been locked as the expiry date has passed.", _
           Title:="Sheets locked"

End Sub
Sub ResetLockDate()
'Allows authorised user to change the lock date
    Dim vP
    Dim dDt As Date
    Dim sMsg As String
   
    vP = InputBox(prompt:="Please enter password to change the lockdate for this workbook", _
                Title:="Password required")
    If vP = sPW Then
        dDt = GetDate
        If dDt <= Date And Date > Range(sLDName) Then
            MsgBox "Date provided does not make sense: the workbook is already locked. No action taken."
        Else
            Range(sLDName) = dDt
            If Range(sWBLName) Then
                UnlockSheets sPW
                Range(sWBLName) = False
                sMsg = "All worksheets have been unlocked. " & vbCrLf
            End If
            MsgBox sMsg & "Lock date set to: " & Format(dDt, "short date")
        End If
    Else
        MsgBox "Incorrect or no password given. No action taken"
    End If
End Sub

and this code into the workbook module:
VBA Code: 
Option Explicit

    Dim vWS

Private Sub Workbook_AfterSave(ByVal Success As Boolean)
'Restore any sheets to unlocked, in case user had unlocked these
    Dim iC As Integer
   
    If Not IsArray(vWS) Then Exit Sub  ' Workbook has not been locked, no action required
    'else
    For iC = 1 To Me.Worksheets.Count
        If vWS(iC) = False Then            'check the original protect status of each sheet
            Worksheets(iC).Unprotect sPW    'unprotect the sheet, the user had unprotected earlier
            Me.Saved = True                 'tell Excel the workbook has been saved
        End If
    Next iC

End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Set all the sheets to locked before saving, if the lock date has passed.
'This in case an authorised user has unlocked a sheet and saves the workbook
    Dim iC As Integer
    Dim wsHS As Worksheet
   
    'to enable saving workbook first time before running the code, need to check if _
     sheet ProtectSupport exists. If not skip the rest.
    On Error Resume Next
    Set wsHS = Sheets(sHDName)
    On Error GoTo 0
    If wsHS Is Nothing Then Exit Sub
   
   
    If Range(sWBLName) = False Then Exit Sub ' Workbook has not been locked, no action required
    'else
    'sometimes hidden sheet gets locked. Unlock
    wsHS.Unprotect sPW
   
    ReDim vWS(1 To Me.Worksheets.Count)
    For iC = 1 To Me.Worksheets.Count
        vWS(iC) = Worksheets(iC).ProtectContents    'store the status of protection for each sheet
        Worksheets(iC).Protect sPW, AllowSorting:=True, AllowFiltering:=True
    Next iC
End Sub

Private Sub Workbook_Open()
   
    FirstTimeSetup
    If Range(sWBLName) = True Then Exit Sub ' Workbook has been locked previously, user has unlocked
       
    'Workbook not locked, check if needs locking
    If Date < Range(sLDName) Then Exit Sub  ' Lockdate has not passed, allow user to use workbook
   
    'Workbook needs to be locked, first time
    SetWB2Locked sPW
End Sub
Click to expand...

hi Sijpie,

Thank you very much for your support,, its perfectly working :)

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

Similar threads

R
  • Solved
Assign Expiry date
Replies
7
Views
635
raji123
R
N
  • Question
Locking a row once a value is entered into a cell
Replies
9
Views
725
arturojab
A
J
  • Question
Locking Worksheet
Replies
3
Views
141
dmt32
D
M
  • Question
Prevent Sharing & Issue With Expiration VBA
2
Replies
11
Views
1K
Candyman8019
C
A
  • Question
Excel table protection with formula copying
Replies
2
Views
557
Allie_Excel
A

Forum statistics

Threads
1,215,152
Messages
6,123,323
Members
449,094
Latest member
Chestertim

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