当前位置：首页 > news >正文

VBA解除Excel工作表保护

news 来源：原创 2024/9/30 20:57:05

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 BooleanApplication.ScreenUpdating = False
Application.DisplayAlerts = FalseWinTag = ActiveWorkbook.ProtectStructure Or ActiveWorkbook.ProtectWindowsShTag = FalseFor Each w1 In WorksheetsShTag = ShTag Or w1.ProtectContentsNext w1If Not ShTag And Not WinTag ThenMsgBox "该工作表没有设置保护密码", , "系统提示"Exit SubEnd IfIf Not WinTag ThenElseOn Error Resume NextDoFor i = 65 To 66: For j = 65 To 66: For k = 65 To 66For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126ActiveWorkbook.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 ThenPWord1 = 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 DoEnd IfNext: Next: Next: Next: Next: NextNext: Next: Next: Next: Next: NextLoop Until TrueOn Error GoTo 0End IfIf WinTag And Not ShTag ThenMsgBox "确保密码唯一的?", , "系统提示"Exit SubEnd IfOn Error Resume NextFor Each w1 In Worksheetsw1.Unprotect PWord1Next w1On Error GoTo 0ShTag = FalseFor Each w1 In WorksheetsShTag = ShTag Or w1.ProtectContentsNext w1If ShTag ThenFor Each w1 In WorksheetsIf w1.ProtectContents ThenOn Error Resume NextDoFor i = 65 To 66: For j = 65 To 66: For k = 65 To 66For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126w1.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 ThenPWord1 = 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 Worksheetsw2.Unprotect PWord1Next w2Exit DoEnd IfNext: Next: Next: Next: Next: NextNext: Next: Next: Next: Next: NextLoop Until TrueOn Error GoTo 0End IfNext w1End IfMsgBox "该工作簿中的工作表密码保护已全部解除!请记得另存", , "系统提示"Application.ScreenUpdating = False
Application.DisplayAlerts = FalseEnd Sub