防止用户删除 Excel 中特定列中具有特定值的特定表中的行

Question

这可能类似于this question，但我相信它在复杂性方面更进了一步，这就是我问它的原因。

上下文：我正在构建一个预算电子表格，可以在表格中创建和删除行。在工作表中，我有两张桌子。一个包含基于类别的总计，而另一个表包含用户可以输入以填充另一个表中的总计的事务。我保护了工作表以防止用户破坏公式，并且只有他们应该编辑的单元格（即输入值）不受保护。我还有用于插入和删除表格上的一行或多行的宏（我对宏进行了编码以在宏运行完成之前和之后取消保护/保护工作表）。

问题：我的问题涉及first table。在该表中，我想确保不能删除“存款”行。问题是，在我的代码中，如何确保用户可以删除另一个包含“存款”的表中的所有其他行，同时防止删除该表中的“存款”行？我正在考虑以下伪代码，但请随时提出其他建议：

'If selected range contains cells in Column A
'and cell in selected range = Deposits
'Then pop error message
'Exit Sub

这是我的删除宏的代码

Sub DeleteRow()
'
' DeleteRow Macro
'
' Keyboard Shortcut: Ctrl+Shift+D
'

Dim loTtest         As ListObject
Dim loSet           As ListObject
Dim c               As Range
Dim arrRows()       As Variant
Dim arrTemp()       As Variant
Dim xFind           As Variant
Dim iCnt            As Long
Dim sMsg            As String

ActiveSheet.Unprotect Password:="PYS"
Erase arrRows()
iCnt = 1
For Each c In Selection.Cells
    If Not c.ListObject Is Nothing Then
        If loSet Is Nothing Then
            Set loSet = c.ListObject
        Else
            If c.ListObject <> loSet Then
                'different table
                MsgBox "You have more than one table selected.", vbInformation, "ERROR!"
                ActiveSheet.Protect Password:="PYS"
                GoTo MyExit
            End If
        End If

        If iCnt = 1 Then
            ReDim arrRows(1 To iCnt)
            arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row
            iCnt = iCnt + 1
        Else
            On Error Resume Next
            xFind = 0
            xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0)
            If xFind = 0 Then
                ReDim Preserve arrRows(1 To iCnt)
                arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row
                iCnt = iCnt + 1
            End If
            Err.Clear
            On Error GoTo 0
        End If

    Else
        'a cell is not in a table
        MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!"
        ActiveSheet.Protect Password:="PYS"
        GoTo MyExit
    End If
Next c

Call SortArray(arrRows())
sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?"
If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then
    ActiveSheet.Protect Password:="PYS"
    Exit Sub
End If

For iCnt = UBound(arrRows) To LBound(arrRows) Step -1

    loSet.ListRows(arrRows(iCnt)).Delete
Next iCnt
ActiveSheet.Protect Password:="PYS"
Exit Sub

MyExit:

End Sub



Sub SortArray(MyArray() As Variant)

Dim iStart          As Long
Dim iEnd            As Long
Dim iStep           As Long
Dim iMove           As Long
Dim vTemp           As Variant

iStart = LBound(MyArray)
iEnd = UBound(MyArray)
For iStep = iStart To iEnd - 1
    For iMove = iStep + 1 To iEnd
        If MyArray(iStep) > MyArray(iMove) Then
            vTemp = MyArray(iMove)
            MyArray(iMove) = MyArray(iStep)
            MyArray(iStep) = vTemp
        End If
    Next iMove
Next iStep

End Sub

顺便说一句，这一切都不是我自己想出来的；我把大部分代码都拼凑了起来。 :) 如果您需要更多信息或上下文，请告诉我。提前致谢！

Here is the link to the budget workbook.

Answer 1

If ActiveSheet.Cells(c.Row, 1).Value = "Deposits" ThenHere 是有效的 DeleteRow sub

Sub DeleteRow()
'
' DeleteRow Macro
'
' Keyboard Shortcut: Ctrl+Shift+D
'

    Dim loTtest         As ListObject
    Dim loSet           As ListObject
    Dim c               As Range
    Dim arrRows()       As Variant
    Dim arrTemp()       As Variant
    Dim xFind           As Variant
    Dim iCnt            As Long
    Dim sMsg            As String

    ActiveSheet.Unprotect Password:="PYS"
    Erase arrRows()
    iCnt = 1

    'This is the loop that I added before anything else to keep people from deleting the row with "Deposits"
    For Each c In Selection.Cells
        If ActiveSheet.Cells(c.Row, 1).Value = "Deposits" Then
            MsgBox "Your Selection contains 'Deposits'!" & vbCrLf & _
                "The 'Deposits' row cannot be deleted!", vbExclamation
            GoTo MyExit
        End If
    Next

    For Each c In Selection.Cells
        If Not c.ListObject Is Nothing Then
            If loSet Is Nothing Then
                Set loSet = c.ListObject
            Else
                If c.ListObject <> loSet Then
                    'different table
                    MsgBox "You have more than one table selected.", vbInformation, "ERROR!"
                    ActiveSheet.Protect Password:="PYS"
                    GoTo MyExit
                End If
            End If

            If iCnt = 1 Then
                ReDim arrRows(1 To iCnt)
                arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row
                iCnt = iCnt + 1
            Else
                On Error Resume Next
                xFind = 0
                xFind = WorksheetFunction.Match(c.Row - loSet.HeaderRowRange.Row, arrRows(), 0)
                If xFind = 0 Then
                    ReDim Preserve arrRows(1 To iCnt)
                    arrRows(iCnt) = c.Row - loSet.HeaderRowRange.Row
                    iCnt = iCnt + 1
                End If
                Err.Clear
                On Error GoTo 0
            End If

        Else
            'a cell is not in a table
            MsgBox "Your selection is all or partially outside of a table.", vbInformation, "ERROR!"
            ActiveSheet.Protect Password:="PYS"
            GoTo MyExit
        End If
    Next c

    Call SortArray(arrRows())
    sMsg = "Are you sure you want to delete " & UBound(arrRows) & " rows from from this table?"
    If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CONTINUE?") <> vbYes Then
        ActiveSheet.Protect Password:="PYS"
        Exit Sub
    End If

    For iCnt = UBound(arrRows) To LBound(arrRows) Step -1
        loSet.ListRows(arrRows(iCnt)).Delete
    Next iCnt
    ActiveSheet.Protect Password:="PYS"
    Exit Sub

MyExit:

End Sub