VBA解除Excel工作表保护

Excel工作表保护解除

　　工作表保护后无法编辑内容，可能是密码忘记，不可暴力破解隐私

1 打开需的Excel

　　2 Alt + F11 打开代码编辑，点击任意代码编辑项，将如下代码复制，并运行。

Public Sub GetWorkbookPassword()

Dim w1 As Worksheet, w2 As Worksheet
Dim i As Integer, j As Integer, k As Integer, l As Integer
Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer
Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer
Dim PWord1 As String
Dim ShTag As Boolean, WinTag As Boolean

Application.ScreenUpdating = False
Application.DisplayAlerts = False


    WinTag = ActiveWorkbook.ProtectStructure Or ActiveWorkbook.ProtectWindows

    ShTag = False
    For Each w1 In Worksheets
        ShTag = ShTag Or w1.ProtectContents
    Next w1

    If Not ShTag And Not WinTag Then
        MsgBox "该工作表没有设置保护密码", , "系统提示"
        Exit Sub
    End If

    If Not WinTag Then
    Else
        On Error Resume Next
        Do
        For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
        For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
        For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
        For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
            ActiveWorkbook.Unprotect Chr(i) & Chr(j) & Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
            If ActiveWorkbook.ProtectStructure = False And ActiveWorkbook.ProtectWindows = False Then
                PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
                Exit Do
            End If

        Next: Next: Next: Next: Next: Next
        Next: Next: Next: Next: Next: Next
        Loop Until True
        On Error GoTo 0
    End If

    If WinTag And Not ShTag Then
        MsgBox "确保密码唯一的?", , "系统提示"
        Exit Sub
    End If

    On Error Resume Next
    For Each w1 In Worksheets
        w1.Unprotect PWord1
    Next w1

    On Error GoTo 0
    ShTag = False

    For Each w1 In Worksheets
        ShTag = ShTag Or w1.ProtectContents
    Next w1

    If ShTag Then
        For Each w1 In Worksheets

            If w1.ProtectContents Then
                On Error Resume Next
                Do
                For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
                For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
                For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
                For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
                    w1.Unprotect Chr(i) & Chr(j) & Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
                    If Not w1.ProtectContents Then
                        PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
                        For Each w2 In Worksheets
                            w2.Unprotect PWord1
                        Next w2
                        Exit Do
                    End If
                Next: Next: Next: Next: Next: Next
                Next: Next: Next: Next: Next: Next
                Loop Until True
                On Error GoTo 0
            End If
        Next w1
    End If
    MsgBox "该工作簿中的工作表密码保护已全部解除!请记得另存", , "系统提示"

Application.ScreenUpdating = False
Application.DisplayAlerts = False

End Sub