Getting Error in VBA coding

nabeelahmed

Board Regular
Joined
Jun 19, 2020
Messages
76
Office Version
  1. 365
Platform
  1. 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:


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



I am Facing Below error...

1602670200903.png
 
Last edited by a moderator:

Some videos you may like

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,871
Office Version
  1. 365
Platform
  1. Windows
What happens when you amend the code like this?
Rich (BB code):
    With ThisWorkbook
        Set wsWS = .Sheets.Add(after:=.Sheets(.Sheets.Count))
            On Error Resume Next
            wsWS.Name = sHDName
            On Error GoTo 0
            .Names.Add Name:=sLDName, RefersTo:=wsWS.Range("A2")
            .Names.Add Name:=sWBLName, RefersTo:=wsWS.Range("A5")
    End With


For future posts:
Using code tags sometimes makes it much easier to understand code quickly
Many members ignore threads where code tags have not been used

Code tags appear when you click on the VBA icon above reply window
[ CODE=vba ][ /CODE ]
If you require to format the font to explain a problem then click on RICH (which is what I did above)
[ CODE=rich ] [ /CODE ]

Paste your code inside the code tags like this
[ CODE=vba ]
With ThisWorkbook
Set wsWS = .Sheets.Add(after:=.Sheets(.Sheets.Count))
On Error Resume Next
wsWS.Name = sHDName
On Error GoTo 0
.Names.Add Name:=sLDName, RefersTo:=wsWS.Range("A2")
.Names.Add Name:=sWBLName, RefersTo:=wsWS.Range("A5")
End With
[ /CODE ]

to achieve this when reply is clicked
VBA Code:
    With ThisWorkbook
        Set wsWS = .Sheets.Add(after:=.Sheets(.Sheets.Count))
            On Error Resume Next
            wsWS.Name = sHDName
            On Error GoTo 0
            .Names.Add Name:=sLDName, RefersTo:=wsWS.Range("A2")
            .Names.Add Name:=sWBLName, RefersTo:=wsWS.Range("A5")
    End With
 

nabeelahmed

Board Regular
Joined
Jun 19, 2020
Messages
76
Office Version
  1. 365
Platform
  1. Windows
What happens when you amend the code like this?
Rich (BB code):
    With ThisWorkbook
        Set wsWS = .Sheets.Add(after:=.Sheets(.Sheets.Count))
            On Error Resume Next
            wsWS.Name = sHDName
            On Error GoTo 0
            .Names.Add Name:=sLDName, RefersTo:=wsWS.Range("A2")
            .Names.Add Name:=sWBLName, RefersTo:=wsWS.Range("A5")
    End With


For future posts:
Using code tags sometimes makes it much easier to understand code quickly
Many members ignore threads where code tags have not been used

Code tags appear when you click on the VBA icon above reply window
[ CODE=vba ][ /CODE ]
If you require to format the font to explain a problem then click on RICH (which is what I did above)
[ CODE=rich ] [ /CODE ]

Paste your code inside the code tags like this
[ CODE=vba ]
With ThisWorkbook
Set wsWS = .Sheets.Add(after:=.Sheets(.Sheets.Count))
On Error Resume Next
wsWS.Name = sHDName
On Error GoTo 0
.Names.Add Name:=sLDName, RefersTo:=wsWS.Range("A2")
.Names.Add Name:=sWBLName, RefersTo:=wsWS.Range("A5")
End With
[ /CODE ]

to achieve this when reply is clicked
VBA Code:
    With ThisWorkbook
        Set wsWS = .Sheets.Add(after:=.Sheets(.Sheets.Count))
            On Error Resume Next
            wsWS.Name = sHDName
            On Error GoTo 0
            .Names.Add Name:=sLDName, RefersTo:=wsWS.Range("A2")
            .Names.Add Name:=sWBLName, RefersTo:=wsWS.Range("A5")
    End With

Dear Yongle, Actually i am not very expert on this page thats why was not much aware about it,, Thank you very much for your guidance :) Will Take care in future posting
 

nabeelahmed

Board Regular
Joined
Jun 19, 2020
Messages
76
Office Version
  1. 365
Platform
  1. Windows
Hi Friends, I was trying to resolve this problem but could't but i got one clue that when i keep my workbook in Local disk in my computer its working perfectly but when i store my workbook in Local Network shared folder its showing error every time i open the workbook.. Please guide me to resolve the issue...

@Toadstool

@Anthony47

Regards,
 

Watch MrExcel Video

Forum statistics

Threads
1,114,002
Messages
5,545,440
Members
410,684
Latest member
LakTik
Top