nabeelahmed
Board Regular
- Joined
- Jun 19, 2020
- Messages
- 76
- Office Version
- 365
- Platform
- Windows
Hi Frieds,
I am using below code for lock my Workbook after specific date but whenever i am opening workbook after putting these codes i am getting error as shown below.Please help me to fix it.
This code into the normal module:
and this code into the workbook module:
I am Facing Below error...
I am using below code for lock my Workbook after specific date but whenever i am opening workbook after putting these codes i am getting error as shown below.Please help me to fix it.
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 Suband 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 SubI am Facing Below error...
Last edited by a moderator:
Will Take care in future posting
