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

Question

我目前正在研究一组代码，该代码根据当前用户的用户名锁定和解锁工作表，没什么特别的。这段代码运行良好，除了在保存后部分。间歇性地，当保存在公司服务器上时，仅在我的计算机上(尽管它仅在 3 台计算机上进行了轻微测试)，我收到 50290 错误，尝试修改工作表的任何内容 - 甚至是 application.wait。最终，我将此追溯到工作簿尚未准备好(application.ready 在保存后返回 false，但如果我手动运行代码或在打开工作簿事件期间返回 true)。似乎标准过程是执行while循环，直到application.ready = true，但这会锁定计算机而无法恢复。我已经尝试过减慢循环速度的方法( sleep 、doevent、等待)，但这些方法似乎都无法解决问题。

有任何想法吗？

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

编辑以删除代码的内部工作。当 excel 准备好并按预期执行操作时，此代码可以正常工作。

Answer 1

让我知道这个如何为您工作。如果它有效并且你想要它，我可以列出我所做的更改

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