Question

允许用户更新受保护工作表中列表对象的内容可能很麻烦。

很高兴我找到了Excel Developers answer，但我还需要允许用户添加或删除行。

下面是我要解决的代码。

（*）欢迎任何改进

Answer 1

将类模块添加到您的VB项目

注意：如果每页只有一个表（列表对象），这将起作用

类名称：cProtectedLO

Option Explicit

' Credits: https://stackoverflow.com/questions/32221328/how-to-protect-a-worksheet-and-unprotect-a-list-object-in-vba

Private Type TTable
    Table As ListObject
    password As String
End Type

Private this As TTable

Private WithEvents appExcel As Excel.Application

Public Property Set Table(ByVal object As ListObject)
Set this.Table = object
End Property

Public Property Let password(ByVal password As String)
this.password = password
End Property

Private Sub Class_Initialize()
    Set appExcel = Excel.Application
End Sub

Private Sub appExcel_SheetChange(ByVal Sh As Object, ByVal Target As Range)

    Dim evalRange As Excel.Range
    Dim currentValue As Variant

    Set evalRange = this.Table.Range

    If Sh Is evalRange.Parent Then
        If Target.Row > 1 Then
            If Not Intersect(Target.Offset(-1), evalRange) Is Nothing Then
                If Intersect(Target, evalRange) Is Nothing Then
                    ' Check if selection is an entire row
                    If Not Target.Cells.Count = Target.EntireRow.Cells.Count Then
                        currentValue = Target.Value
                        Sh.Unprotect password:=IIf(Len(this.password), this.password, Null)
                        With Application
                            .EnableEvents = False
                            .Undo
                            Target.Value = currentValue
                            'Sh.Cells.Locked = True
                            this.Table.DataBodyRange.Locked = False
                            this.Table.Range(this.Table.Range.Rows.Count, 1).Offset(1, 0).Resize(1, this.Table.ListColumns.Count).Locked = False
                            .EnableEvents = True
                        End With
                        Target.Offset(1).Select
                        Sh.Protect password:=IIf(Len(this.password), this.password, Null), UserInterfaceOnly:=True, AllowFormattingRows:=True, AllowUsingPivotTables:=True, AllowDeletingRows:=True, AllowInsertingRows:=True
                    End If
                End If
            ' If user is writing somthing in a row
            ElseIf Not Intersect(Target.EntireRow, evalRange) Is Nothing Then
                ' User has selected a row and begins typing (as the row is unprotected). Undo whatever user is doing
                If Sh.ProtectContents = True Then
                    With Application
                        .EnableEvents = False
                        .Undo
                        .EnableEvents = True
                    End With
                End If
            End If
        End If
    End If
End Sub

Private Sub Class_Terminate()
    Set this.Table = Nothing
    Set appExcel = Nothing
End Sub

Private Sub appExcel_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

    Dim evalRange As Range
    Dim IsProtected As Boolean

    Set evalRange = this.Table.Range


    If Sh Is evalRange.Parent Then

        ' Check if user is copying / cutting cells and is selecting the entire row
        If Target.Row > 1 Then
            If Not Intersect(Target.Offset(-1), evalRange) Is Nothing And Application.CutCopyMode = 0 And Target.Cells.Count = Target.EntireRow.Cells.Count Then

                ' Unlock row if it's at the same listobject range (plus the row below the bottom)
                If Not Intersect(Target, evalRange.Resize(evalRange.Cells.Rows.Count + 1, evalRange.Cells.Columns.Count)) Is Nothing Then
                    IsProtected = False
                Else
                    IsProtected = True
                End If

                Target.EntireRow.Locked = IsProtected

            End If
        End If
    End If

End Sub

添加标准模块模块名称：mSecurity

Option Explicit

Public colProtectedTable As Collection

Public Sub ProtectWorkbook(Optional ByVal password As Variant)

    Dim lProtectedTable As cProtectedLO
    Dim evalSheet As Worksheet
    Dim evalListObject As ListObject

    ' Initialize the collection to store current workbook listobjects
    Set colProtectedTable = New Collection

    ' Loop through all worksheets in current workbook
    For Each evalSheet In ThisWorkbook.Worksheets

        ' If the evaluated worksheet has excel structured tables (listobjects)
        If evalSheet.ListObjects.Count > 0 Then

            ' If it does, loop through all of listobjects
            For Each evalListObject In evalSheet.ListObjects

                ' Initialize the class that handles the protected list objects
                Set lProtectedTable = New cProtectedLO

                With lProtectedTable
                    ' Add the listobject to the class
                    Set .Table = evalListObject

                    ' In case it's specified, add the password to the class property
                    If Not IsMissing(password) Then
                        .password = password
                    End If

                End With

                ' In case sheet is protected, unprotect it
                evalSheet.Unprotect password:=password

                ' if the listobject is not empty, unblock its cells
                If Not evalListObject.DataBodyRange Is Nothing Then
                    evalListObject.DataBodyRange.Locked = False
                End If

                ' Unlock cells bellow table (so user can add data and the table auto-expands
                evalListObject.Range(evalListObject.Range.Rows.Count, 1).Offset(1, 0).Resize(1, evalListObject.ListColumns.Count).Locked = False

                ' Add the class to the collection so it remains usable
                colProtectedTable.Add Item:=lProtectedTable

            Next evalListObject

        End If

        ' Protect current sheet
        evalSheet.Protect password:=password, UserInterfaceOnly:=True, AllowFormattingRows:=True, AllowUsingPivotTables:=True, AllowDeletingRows:=True, AllowInsertingRows:=True

        ' Allow expanding grouped rows and columns
        evalSheet.EnableOutlining = True

    Next evalSheet

End Sub

运行保护：

ProtectWorkbook

如何在VBA中保护工作表和取消保护列表对象（扩展到删除和添加行）

1 个答案: