How to Recover Forgotten Passwords For Microsoft Excel Worksheets

This Macro works exceptionally well to recover and remove passwords from Microsoft Excel Worksheets to allow modification of protected cells

Excel 2000/2003/2007: select Tools --> Macro --> Visual Basic Editor

Excel 2010Navigate to View tab and Click Macros drop down button, and hit Record Macro.
The Record Macro dialog opens, enter a name and hot-key for easier access. 
From the Store Macro In drop-down list, select where you want to store the macro: This Workbook
Hit OK to start recording.

All Versions:

Copy the code below and paste it into the Editor, then push the Play button

<Copy Code below>

Public Sub AllInternalPasswords() 
'Breaks worksheet and workbook structure passwords. 
'Bob McCormick probably originator of base code algorithm 
'Modified for coverage of workbook structure / windows 
'passwords and for multiple passwords 
'Norman Harker and JE McGimpsey 27-Dec-2002 
'Reveals passwords NOT "the" passwords 
Const DBLSPACE As String = vbNewLine & vbNewLine 
Dim Mess As String, Header As String 
Dim Authors As String, Version As String 
Dim RepBack As String, AllClear As String 
Dim PWord1 As String 
Dim ShTag As Boolean, WinTag As Boolean 
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 
Application.ScreenUpdating = False 
Header = "AllInternalPasswords User Message" 
Authors = DBLSPACE & vbNewLine & "Adapted from Bob " & _ 
"McCormick base code by Norman Harker " & _ 
"and JE McGimpsey" 
Version = DBLSPACE & "Version 1.1 27-Dec-2002" 
RepBack = DBLSPACE & "Please report success or " & _ 
"failure back to newsgroup." 
AllClear = DBLSPACE & "The workbook should now " & _ 
"be free of all password protection so " & _ 
"make sure you:" & DBLSPACE & _ 
"SAVE IT NOW!" & DBLSPACE & _ 
"and also" & DBLSPACE & _ 
"BACKUP!, BACKUP!!, BACKUP!!!" & DBLSPACE & _ 
"Also, remember that the password " & _ 
"was put there for a reason. Don't " & _ 
"stuff up crucial formulas or data." & _ 
DBLSPACE & "Access and use of some data may" & _ 
"be an offence. If in doubt, don't." 
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 
Mess = "There were no passwords on sheets, or workbook " & _ 
"structure or windows." & Authors & Version 
MsgBox Mess, vbInformation, Header 
Exit Sub 
End If 
Mess = "After pressing OK button this will take some time." & _ 
DBLSPACE & "Amount of time depends on how " & _ 
"many different passwords, the passwords, and" & _ 
"your computer's specification." & DBLSPACE & _ 
"Just be patient! Make me a coffee!" & _ 
Authors & Version 
MsgBox Mess, vbInformation, Header 
If Not WinTag Then 
Mess = "There was no protection to workbook structure " & _ 
"or windows." & DBLSPACE & _ 
"Proceeding to unprotect sheets." & _ 
Authors & Version 
MsgBox Mess, vbInformation, Header 
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) 
Mess = "You had a Worksheet Structure or " & _ 
"Windows Password set." & DBLSPACE & _ 
"The password found was: " & DBLSPACE & _ 
PWord1 & DBLSPACE & "Note it down for " & _ 
"potential future use in other " & _ 
"workbooks by same person who set this " & _ 
"password." & DBLSPACE & _ 
"Now to check and clear other passwords." & _ 
Authors & Version 
MsgBox Mess, 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 
Mess = "Only structure / windows protected with " & _ 
"the password that was just found." & _ 
AllClear & Authors & Version & RepBack 
MsgBox Mess, 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 Not ShTag Then 
Mess = AllClear & Authors & Version & RepBack 
MsgBox Mess, vbInformation, Header 
Exit Sub 
End If 
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 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 
.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 .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) 
Mess = "You had a Worksheet password set." & _ 
DBLSPACE & "The password found was: " & _ 
DBLSPACE & PWord1 & DBLSPACE & _ 
"Note it down for potential future use " & _ 
"in other workbooks by same person who " & _ 
"set this password." & DBLSPACE & _ 
"Now to check and clear other passwords." & _ 
Authors & Version 
MsgBox Mess, vbInformation, Header 
'leverage finding Pword by trying on other sheets 
For Each w2 In Worksheets 
w2.Unprotect PWord1 
Next w2 
Exit Do 'Bypass all for...nexts 
End If 
Next: Next: Next: Next: Next: Next 
Next: Next: Next: Next: Next: Next 
Loop Until True 
On Error GoTo 0 
End If 
End With 
Next w1 
Mess = AllClear & Authors & Version & RepBack 
MsgBox Mess, vbInformation, Header 
End Sub 

<Copy code above>

credit source: http://www.mrexcel.com/