EXCEL中利用VBA一次性撤销与保护多个工作表的问题？
Posted
tags:
篇首语：本文由小常识网(cha138.com)小编为大家整理，主要介绍了EXCEL中利用VBA一次性撤销与保护多个工作表的问题？相关的知识，希望对你有一定的参考价值。
保护所有工作表代码：
Sub ProtectAll()Dim sht As WorksheetFor Each sht In Worksheetssht.Protect Password:="123"NextEnd Sub
撤销所有保护代码：
Sub UnProtectAll()Dim sht As WorksheetFor Each sht In Worksheetssht.Unprotect Password:="123"NextEnd Sub
问题来了，当运行保护所有工作表时没有什么问题，但是当撤销工作表时却不需要再输密码了，请各位大神予以修改一下代码，使撤销工作表时弹出密码输入窗口，如果密码输入正确则取消保护所有工作表，如果密码输入错误，则提示“密码错误！”，然后单击“确定”取消。
'撤销所有保护代码:
Sub UnProtectAll()
Dim sht As Worksheet
myNum = Application.InputBox("请输入密码：", "撤销所有保护")
If myNum = "123" Then
For Each sht In Worksheets
sht.Unprotect Password:="123"
Next
Else
MsgBox "密码错误！"
End If
End Sub
参考技术A 呃，这样的话，只能通过窗体来过渡了。追问
你好，我现在就是做了两个窗体来承载上面两个宏，问题是，第一个还可以，第二个就不行了，因为取消保护时不需要输入密码就能取消了，所以您能否帮我修改下代码？
追答呃，你说的应该是模块吧……
在窗体上画一个文字框
然后在画一个按钮
双击按钮
Private Sub CommandButton1_Click()
dim mima as string
Dim sht As Worksheet
mima="123"
if textbox1.text=mima then
For Each sht In Worksheets
sht.Unprotect Password:="123"
Next
else
msgbox "密码错误"
end if
End Sub
或者
Sub UnProtectAll()
Dim sht As Worksheet,mima as string,inmima
mima="123"
inmima= inputbox("密码:")
if inmima=mima then
For Each sht In Worksheets
sht.Unprotect Password:=mima
Next
else
msgbox "密码错误"
end if
End Sub
Dim sht As Worksheet
For Each sht In Worksheets
sht.Unprotect
Next
End Sub
Sub ProtectAll()
Dim sht As Worksheet
For Each sht In Worksheets
sht.Protect Password:="123"
Next
End Sub追问
如果把那个PASSWORD 去掉的话，就要每个工作表都输入一次密码来解锁啦，那么这样的话用宏就没意义了，我想要的效果是，只输入一次密码，就能解开所有工作表的密码~~嘻嘻
追答Sub UnProtectAll()Dim sht As Worksheet
Dim sPwd As String
Dim bln As Boolean
On Error GoTo MyErr
bln = False
sPwd = InputBox("请输入密码！")
For Each sht In Worksheets
sht.Unprotect Password:=sPwd
GoTo MySuccess
MyErr:
bln = True
MySuccess:
If bln Then
MsgBox "密码错误！"
Call ProtectAll
exit sub
End If
Next
End Sub
Sub ProtectAll()
Dim sht As Worksheet
For Each sht In Worksheets
sht.Protect Password:="123"
Next
End Sub
在excel中如何取消工作表的保护命令
在excel中取消工作表的保护命令的方法：
1.打开excel，运行视图—宏—录制新宏—输入宏名如:aa（aa是可随意输入）。
2.停止录制，这样得到一个空宏。
3.同样视图—宏—查看宏—选aa（aa为之前新建的宏）—点击编辑按钮。
4.删除窗口中的所有字符，复制下面的内容粘贴。
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 (Version 1.1)
' Modified 2003-Apr-04 by JEM: All msgs to constants, and
' eliminate one Exit Sub (Version 1.1.1)
' Reveals hashed passwords NOT original passwords
Const DBLSPACE As String = vbNewLine & vbNewLine
Const AUTHORS As String = DBLSPACE & vbNewLine & _
"Adapted from Bob McCormick base code by" & _
"Norman Harker and JE McGimpsey"
Const HEADER As String = "AllInternalPasswords User Message"
Const VERSION As String = DBLSPACE & "Version 1.1.1 2003-Apr-04"
Const REPBACK As String = DBLSPACE & "Please report failure " & _
"to the microsoft.public.excel.programming newsgroup."
Const ALLCLEAR As String = 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 offense. If in doubt, don't."
Const MSGNOPWORDS1 As String = "There were no passwords on " & _
"sheets, or workbook structure or windows." & AUTHORS & VERSION
Const MSGNOPWORDS2 As String = "There was no protection to " & _
"workbook structure or windows." & DBLSPACE & _
"Proceeding to unprotect sheets." & AUTHORS & VERSION
Const MSGTAKETIME As String = "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
Const MSGPWORDFOUND1 As String = "You had a Worksheet " & _
"Structure or Windows Password set." & DBLSPACE & _
"The password found was: " & DBLSPACE & "$$" & DBLSPACE & _
"Note it down for potential future use in other workbooks by " & _
"the same person who set this password." & DBLSPACE & _
"Now to check and clear other passwords." & AUTHORS & VERSION
Const MSGPWORDFOUND2 As String = "You had a Worksheet " & _
"password set." & DBLSPACE & "The password found was: " & _
DBLSPACE & "$$" & 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
Const MSGONLYONE As String = "Only structure / windows " & _
"protected with the password that was just found." & _
ALLCLEAR & AUTHORS & VERSION & REPBACK
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
MsgBox MSGNOPWORDS2, 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)
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 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)
MsgBox Application.Substitute(MSGPWORDFOUND2, _
"$$", PWord1), 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
End If
MsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK, vbInformation, HEADER
End Sub
5.关闭编辑窗口。
6.视图—宏—查看宏,选AllInternalPasswords，点击执行，确定两次，等2分钟，再确定。密码撤销完毕。
以上是关于EXCEL中利用VBA一次性撤销与保护多个工作表的问题？的主要内容，如果未能解决你的问题，请参考以下文章