听起来，根据 cmets 的说法，这与其说是一个安全问题，不如说是一个方便问题。因此，在考虑将其实施到您的项目时请记住，如果有任何恶意意图获得未经授权的访问，这很容易被破坏。
首先，我会推荐一个通用着陆区。打开工作簿后立即显示的主工作表。为此，我们将使用Workbook_Open() 事件并从那里激活一个工作表。
如果需要，这可以是隐藏的工作表，这取决于您。
Option Explicit
Private lastUsedSheet As Worksheet
Private Sub Workbook_Open()
Set lastUsedSheet = Me.Worksheets("MainSheet")
Application.EnableEvents = False
lastUsedSheet.Activate
Application.EnableEvents = True
End Sub
接下来，我们应该决定在尝试访问新工作表时应该发生什么。在下面的方法中，一旦激活了工作表，它将自动将用户重定向回上次使用的工作表，直到密码尝试成功。
我们可以在模块范围的变量中跟踪最后使用的工作表，在本例中将命名为lastUsedSheet。每次成功更改工作表时，此变量都会自动设置为该工作表 - 这样，当有人尝试访问另一个工作表时，它会将他们重定向回前一个工作表，直到成功输入密码。
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
On Error GoTo SafeExit
Application.EnableEvents = False
' Error protection in case lastUsedSheet is nothing
If lastUsedSheet Is Nothing Then
Set lastUsedSheet = Me.Worksheets("MainSheet")
End If
' Allow common sheets to be activated without PW
If Sh.Name = "MainSheet" Then
Set lastUsedSheet = Sh
Sh.Activate
GoTo SafeExit
Else
' Temporarily send the user back to last sheet until
' Password has been successfully entered
lastUsedSheet.Activate
End If
' Set each sheet's password
Dim sInputPW As String, sSheetPW As String
Select Case Sh.Name
Case "Sheet1"
sSheetPW = "123456"
Case "Sheet2"
sSheetPW = "987654"
End Select
' Create a loop that will keep prompting password
' until successful pw or empty string entered
Do
sInputPW = InputBox("Please enter password for the " & _
"worksheet: " & Sh.Name & ".")
If sInputPW = "" Then GoTo SafeExit
Loop While sInputPW <> sSheetPW
Set lastUsedSheet = Sh
Sh.Activate
SafeExit:
Application.EnableEvents = True
If Err.Number <> 0 Then
Debug.Print Time; Err.Description
MsgBox Err.Description, Title:="Error # " & Err.Number
End If
End Sub
旁注，禁用事件是必要的，因为您的Workbook_SheetActivate 事件将在成功更改工作表后继续触发。
防止在SaveAs1 期间更改文件类型
您可以通过限制文件保存类型来进一步防止意外删除 VBA 代码。这可以使用Workbook_BeforeSave() 事件来完成。这是一个潜在问题的原因是，保存为未启用宏的工作簿会擦除代码，这将阻止您刚刚在上面实现的密码保护功能。
首先，我们需要检查这是Save 还是SaveAs。您可以使用事件本身包含的布尔属性SaveAsUI 来完成此操作。如果这个值为True，那么它就是一个SaveAs 事件——这意味着我们需要执行额外的检查以确保文件类型不会从保存对话框中意外更改。如果值为False，那么这是正常保存，我们可以绕过这些检查，因为我们知道工作簿将保存为.xlsm类型。
经过初步检查，我们将使用Application.FileDialog().Show显示对话框。
之后，我们会检查用户是否取消了操作.SelectedItems.Count = 0或点击了保存。如果用户点击取消，那么我们只需设置Cancel = True，工作簿将不会保存。
我们继续检查用户使用此行选择的扩展类型：
If Split(fileName, ".")(UBound(Split(fileName, "."))) <> "xlsm" Then
这将用句点. 分割文件路径，并在文件名可能包含其他句点的情况下获取句点(UBound(Split(fileName, "."))) 的最后一个实例。如果扩展名与xlsm 不匹配，则中止保存操作。
最后，所有检查通过后，您可以保存文档：
Me.SaveAs .SelectedItems(1), 52
由于我们已经用上面的行保存了它，我们可以继续设置Cancel = True并退出例程。
完整代码（要放在Worksheet obj模块中）：
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
On Error GoTo SafeExit
If SaveAsUI Then
With Application.FileDialog(msoFileDialogSaveAs)
.Show
If .SelectedItems.Count = 0 Then
Cancel = True
Else
Dim fileName$
fileName = .SelectedItems(1)
If Split(fileName, ".")(UBound(Split(fileName, "."))) <> "xlsm" Then
MsgBox "You must save this as an .xlsm document. Document has " & _
"NOT been saved", vbCritical
Cancel = True
Else
Application.EnableEvents = False
Application.DisplayAlerts = False
Me.SaveAs .SelectedItems(1), 52
Cancel = True
End If
End If
End With
Else
Exit Sub
End If
SafeExit:
Application.EnableEvents = True
Application.DisplayAlerts = True
If Err.Number <> 0 Then
Debug.Print Time; Err.Description
MsgBox Err.Description, Title:="Error # " & Err.Number
End If
End Sub
1 向PatricK 提出建议