神技 破解EXCEL工作表保護密碼 http://www.mr-wu.cn/crack-excel-workbook-protection/
我們可以通過新建工作本，來創建一個新的工作本來創造新的宏而繞過密碼保護機制。
在打開的PDN_Tool_v1_1_1.xls工作本里，通過菜單“文件–>新建工作本“，創建一個新的空白工作本。
在新建的工作本里，通過菜單”工具–>宏–>錄制新宏…“來創建一個新的宏。
但我們這里先什么都不用做，直接菜單”工具–>宏–>停止錄制“來創建一個空白的宏，我們會對這個新的宏進行編輯工作。
通過菜單”工具–>宏–>宏…“，來打開宏選擇窗口，我們會在宏窗口的選擇列表里看到我們剛才新建的那個宏”hh”。
選擇宏“hh”，然后點擊“編輯”按鈕。
在彈出的“Visual Basic 編輯器”窗口右邊，刪除原有的代碼，將下邊的VBA代碼粘貼減去，然后關閉“Visual Basic 編輯器”窗口。
Public Sub 工作表保護密碼破解() Const DBLSPACE As String = vbNewLine & vbNewLine Const AUTHORS As String = DBLSPACE & vbNewLine & _ "作者:McCormick JE McGimpsey " Const HEADER As String = "工作表保護密碼破解" Const VERSION As String = DBLSPACE & "版本 Version 1.1.1" Const REPBACK As String = DBLSPACE & "" Const ZHENGLI As String = DBLSPACE & " 吳川斌的博客 www.mr-wu.cn" Const ALLCLEAR As String = DBLSPACE & "該工作簿中的工作表密碼保護已全部解除!!" & DBLSPACE & "請記得另保存" _ & DBLSPACE & "注意：不要用在不當地方，要尊重他人的勞動成果！" Const MSGNOPWORDS1 As String = "該文件工作表中沒有加密" Const MSGNOPWORDS2 As String = "該文件工作表中沒有加密2" Const MSGTAKETIME As String = "解密需花費一定時間,請耐心等候!" & DBLSPACE & "按確定開始破解!" Const MSGPWORDFOUND1 As String = "密碼重新組合為:" & DBLSPACE & "$$" & DBLSPACE & _ "如果該文件工作表有不同密碼,將搜索下一組密碼並修改清除" Const MSGPWORDFOUND2 As String = "密碼重新組合為:" & DBLSPACE & "$$" & DBLSPACE & _ "如果該文件工作表有不同密碼,將搜索下一組密碼並解除" Const MSGONLYONE As String = "確保為唯一的?" 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 With ActiveWorkbook WinTag = .ProtectStructure Or .ProtectWindows End With ShTag = False For Each w1 In Worksheets ShTag = ShTag Or w1.ProtectContents Next w1 If Not ShTag And Not WinTag Then MsgBox MSGNOPWORDS1, vbInformation, HEADER Exit Sub End If MsgBox MSGTAKETIME, vbInformation, HEADER If Not WinTag Then Else On Error Resume Next Do 'dummy do loop 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 With 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 .ProtectStructure = False And _ .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) MsgBox Application.Substitute(MSGPWORDFOUND1, _ "$$", PWord1), vbInformation, HEADER Exit Do 'Bypass all for...nexts End If End With 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 MSGONLYONE, vbInformation, HEADER Exit Sub End If On Error Resume Next For Each w1 In Worksheets 'Attempt clearance with PWord1 w1.Unprotect PWord1 Next w1 On Error GoTo 0 ShTag = False For Each w1 In Worksheets 'Checks for all clear ShTag triggered to 1 if not. ShTag = ShTag Or w1.ProtectContents Next w1 If ShTag Then For Each w1 In Worksheets With w1 If .ProtectContents Then On Error Resume Next Do 'Dummy do loop For i = 65 To 66: For j = 65 To 66: For k = 65