保护特定的工作表按钮？

Question

您好，我有一个按钮，可以让我的老板根据他输入的工作表名称来删除工作簿中众多工作表中的其中一个工作表。此删除工作表按钮受密码保护，因为其他人使用工作簿我不希望他们删除任何内容。

现在这不会阻止他们右键单击特定工作表并删除，因此我需要一种方法来在未按下“删除工作表”按钮时保护所有工作表，并在正确输入该按钮的密码后取消保护所有工作表, 因为按钮无法移除受保护的工作表。

删除工作表按钮代码：

    Private Sub CommandButton4_Click()

Dim delSheet As String
Dim response As String
Dim SheetFound As Boolean
Dim MyPass As String
Dim MyPasswrd As String, answ As String

 MyPasswrd = "test"                                                             'password verification puts trigger in cell A100, an deletes when file close
 If Range("A101").Value <> "OK" Then
     answ = InputBox("Please Enter The Password To Continue.", "Enter Password")
        If answ <> MyPasswrd Then
             MsgBox "Incorrect Password!", vbExclamation, "Warning"
            Exit Sub
        End If
    Range("A101").Value = "OK"
End If

delSheet = InputBox("Please Enter The LAST NAME Of The DTS You Want To Remove", "Remove A DTS")                     'user input

If delSheet = "" Then
MsgBox "You Did Not Complete The Entry.", vbOKOnly + vbInformation, "Warning"                       'if NULL input displays this message
Exit Sub

Else
  If IsLetter(delSheet) = False Then GoTo Display                                                   'checks the user input

response = MsgBox("WARNING!! This Action Cannot Be Undone, Do You Still Want To Continue?", vbExclamation + vbYesNo, "Warning")     'verfies user input


If response = vbYes Then                                                                'if input is yes  selects sheet IF ITS FOUND
On Error Resume Next

        ActiveWorkbook.Sheets(delSheet).Select
        If Err = 0 Then SheetFound = True                                               'searches for sheet

    On Error GoTo 0

    If SheetFound = False Then                                                      'if sheet not found displays this message

        MsgBox prompt:="The sheet '" & delSheet & "' Could Not Be Found In This File!", Buttons:=vbExclamation, Title:="Search Result"
        Exit Sub

    Else

 Application.DisplayAlerts = False                                                  'Finally deletes sheet and bypass xcel warning for sheet deletion
 Sheets(delSheet).Delete
 Application.DisplayAlerts = True

MsgBox ("The DTS " & delSheet & " Was Successfully Removed")                                    'message for sucessfully deleting the sheet
Application.Goto Reference:=Worksheets("Control Center").Range("B1"), Scroll:=True
End If

Else

response = vbNo                                                                         'if user does not want to delete sheet exits window
Exit Sub

Display:
     MsgBox "Invalid Character In Last Name. Please Only Use Letters And Numbers(1-9), NOT Spaces and Specail Characters (! @ # $ % ^ & * - + = \ _ .)", vbExclamation, "Warning"

End If
End If
End Sub

Answer 1

如果您有 Excel-2013 或 Excel-2016 那么，您可以使用Workbook_SheetBeforeDelete 事件。 在工作簿模块中添加以下代码：

Option Explicit

Public IsPasswordOK  As Boolean
Public IsDeleteOK    As Boolean

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    If Not IsDeleteOK Then
        MsgBox "You deleted a sheet without permission. Can't save the file."
        Cancel = True
    End If
End Sub

Private Sub Workbook_Open()
    IsDeleteOK = True
End Sub

Private Sub Workbook_SheetBeforeDelete(ByVal Sh As Object)
    If IsDeleteOK Then
        IsDeleteOK = IsPasswordOK
    End If
End Sub

---

在 CommandButton4_Click() 代码行 Sheets(delSheet).Delete 之后添加此行

ThisWorkbook.IsPasswordOK=True

---

对于 Excel-2013

之前的版本

首先添加一个模块名称mdlSheetWatch。在该模块中添加以下代码。

Option Explicit

Public IsPasswordOK  As Boolean
Public dctSheets
Public Function IsSheetsOk()

    Dim wks As Worksheet
    Dim lCtr    As Long
    Dim bResult As Boolean

    If IsPasswordOK Then
        bResult = True
        Exit Function
    Else

       bResult = True
        For Each wks In ThisWorkbook.Worksheets
           If Not dctSheets.exists(wks.CodeName) Then
            bResult = False
            Exit For
           End If
        Next

    End If

    IsSheetsOk = bResult

End Function

Public Function LoadSheetList() As Object
     Dim wks As Worksheet
     Dim dctTemp As Object

     Set dctTemp = CreateObject("Scripting.Dictionary")

      For Each wks In ThisWorkbook.Worksheets
        dctTemp.Add wks.CodeName, wks.Name
      Next

    Set LoadSheetList = dctTemp

End Function

---

现在在工作簿模块中，添加以下代码

Option Explicit

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    If Not mdlSheetWatch.IsSheetsOk Then
        MsgBox "You deleted/renamed a sheet without permission. Can't save the file."
        Cancel = True
    End If
End Sub

Private Sub Workbook_Open()
   Set dctSheets = mdlSheetWatch.LoadSheetList
End Sub

---

最后，在CommandButton4_Click() 代码行之后 Sheets(delSheet).Delete 添加这一行

mdlSheetWatch.IsPasswordOK=True

---

这应该防止没有密码的用户在删除/重命名/添加工作表后保存工作簿。

Answer 2

Worksheet 类的事件BeforeDelete 没有Cancel 选项，但这是执行取消操作的解决方法。

1- 在一个普通的模块中，放入这个例程：

Sub unprotectThis()
    ThisWorkbook.unprotect
End Sub

2- 在要防止删除的工作表的代码模块中，添加此事件处理程序：

Private Sub Worksheet_BeforeDelete()
    ThisWorkbook.Protect
    MsgBox "This sheet can be deleted only by the administrator through the dedicated button", vbExclamation
    Application.OnTime Now + TimeSerial(0, 0, 1), "unprotectThis"
End Sub

我们以某种方式“模拟”了取消选项。一秒钟后，工作簿将再次不受保护。

3- 最后，在按钮的处理程序中，您要求输入密码，在实际执行删除之前禁用事件。这不会调用上面的 Worksheet_BeforeDelete 处理程序。在离开之前恢复事件：

Private Sub CommandButton4_Click()
    On Error goto RestoreEvents
    Application.EnableEvents = false
    ...
    ' your routine that checks for password and performs the delete...
    ...
RestoreEvents:
    Application.EnableEvents = true
End Sub

请注意，此解决方案甚至不需要保护工作簿，它只保护给定的工作表。