Excel VBA: Protect/Unprotect macro breaks during saves due to not ready - excel

Question

I'm currently working on a set of code that locks and unlocks a sheet based on the username of the current user, nothing fancy. This code works quite well, except during the after save portion. Intermittently, when saved on the company server, on my computer only (though its only been lightly tested on 3 computers), I get a 50290 error with anything that tries to modify the sheet - even application.wait. Eventually I traced this to the workbook not being ready (application.ready returns false after save, but true if I manually run the code or during the open workbook event). It seems that the standard procedure is to do while loop until application.ready = true, but that locks the computer up with no recovery. I've tried methods of slowing the loop down (sleep, doevent, wait) and none of those seem to fix the issue.
Any ideas?
Sub AuthorizedUser()
- initialize variables here
On Error GoTo errorhandler
Do 'attempt to wait until sheet is ready
DoEvents
Loop Until Application.Ready = True
- Do stuff to protect sheet here -
- If the sheet isn't ready, error state -
- Any change, such as application.wait, coloring cells, or protecting sheet is what the error state occurs on -
errorhandler:
MsgBox "Unlocker broke. Please hit the unlock button"
End Sub
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Call AuthorizedUser
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
- do stuff to protect worksheet -
End Sub
Private Sub Workbook_Open()
Call AuthorizedUser
Application.Run "sheet1.ClearSheet"
End Sub
editted to remove the inner workings of the code. This code works just fine when excel is ready and does things as intended.

Answer 1

Let me know how this one works for you. If it works and you want it, I can make a list of the changes that I made
Option Explicit
Private Const THE_PASSWORD As String = "TDM"
Private Sub Auto_Open()
Call AuthProtect(False)
ThisWorkbook.Sheets(1).Cells.Clear
End Sub
Private Function GetAuth() As Long
With ThisWorkbook.Sheets("Authorized users")
Dim managers As Range
Set managers = .Range("A1").Resize(.Range("A1").End(xlDown).Row)
Dim workers As Range
Set workers = .Range("B1").Resize(.Range("B1").End(xlDown).Row)
End With
On Error GoTo errorhandler
While Not Application.Ready
DoEvents
Wend
On Error GoTo 0
Dim currentUser As String
currentUser = Environ$("username")
Dim auth As Long
Dim cell As Range
For Each cell In Union(managers, workers)
If LCase$(currentUser) = LCase$(cell.Value2) Then
auth = cell.Column
Exit For
End If
Next cell
GetAuth = auth
Exit Function
errorhandler:
GetAuth = -1
End Function
Private Sub AuthProtect(ByVal doProtect As Boolean)
On Error GoTo errorhandler
SpeedUp True
If doProtect Then
With ThisWorkbook
.Unprotect THE_PASSWORD
With .Sheets("Authorized users")
.Unprotect THE_PASSWORD
.Columns("B").Locked = True
.Protect THE_PASSWORD
.Visible = xlVeryHidden
End With
With .Sheets("Part Tracker")
.Unprotect THE_PASSWORD
.Rows("6:" & Rows.Count).Locked = True
.Protect THE_PASSWORD
End With
.Protect THE_PASSWORD
End With
Else
Select Case GetAuth
Case 1
With ThisWorkbook
.Unprotect THE_PASSWORD
With .Sheets("Authorized users")
.Visible = xlSheetVisible
.Unprotect THE_PASSWORD
.Columns("B").Locked = False
.Protect THE_PASSWORD
End With
.Protect THE_PASSWORD
End With
Case 2
With ThisWorkbook.Sheets("Part Tracker")
.Unprotect THE_PASSWORD
.Rows("6:" & Rows.Count).Locked = False
.Protect THE_PASSWORD, _
AllowInsertingRows:=True, _
AllowInsertingHyperlinks:=True, _
AllowDeletingRows:=True, _
AllowFiltering:=True, _
UserInterfaceOnly:=True, _
DrawingObjects:=False
.EnableOutlining = True
End With
Case -1
MsgBox "Error with Application.Ready state"
Case Else
With ThisWorkbook.Sheets("Authorized users")
Dim managers As Range
Set managers = .Range("A1").Resize(.Range("A1").End(xlDown).Row)
End With
Dim managerList As String
Dim cell As Range
For Each cell In managers
managerList = managerList & " " & cell.Value2 & vbCrLf
Next cell
MsgBox "You do not have write access to this file." & vbNewLine & "To request access, please seek out any of the following managers: " & vbCrLf & vbCrLf & managerList
End Select
End If
errorhandler:
SpeedUp False
End Sub
Sub SpeedUp(ByVal toggleOn As Boolean)
With Application
.Calculation = IIf(toggleOn, xlCalculationManual, xlCalculationAutomatic)
.ScreenUpdating = Not toggleOn
.DisplayStatusBar = Not toggleOn
.EnableEvents = Not toggleOn
End With
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Call AuthProtect(True)
End Sub
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Call AuthProtect(False)
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call AuthProtect(True)
End Sub