How to protect a worksheet and unprotect a list object in vba (extended to deleting and adding rows)

Question

Allowing a user to update the content of listobjects in protected sheets can be cumbersome.

Gladly I found Excel Developers answer but I also needed to allow the user to add or delete rows.

Below is my code to solve it.

(*) Any improvements are welcome

Answer 1

Add a class module to your VB project

Note: This will work if you have only one table (listobject) per page

Class name: 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

Add a standard module Module name: 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

Run the protection with:

ProtectWorkbook