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

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