Adding a ListRow into a table of a protected worksheet

Question

I want to add data to last row in each table in each worksheet when the worksheet is protected.

I have this code in ThisWorkbook to protect the worksheets

Private Sub Workbook_Open()
    Dim wSheet As Worksheet
    For Each wSheet In Worksheets
        wSheet.Protect Password:="Secret", _
        UserInterFaceOnly:=True
    Next wSheet
End Sub

and the following code to add the data. It throws

Error 1004 "Application-defined or Object-defined error"

at the Set newrow1 = tbl.ListRows.Add when the worksheet is protected.

Sub AddDataToTable()
    Application.ScreenUpdating = False
    Dim MyValue As String
    Dim sh As Worksheet
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet
    Dim ws4 As Worksheet
    Dim ws5 As Worksheet
    Set ws1 = Sheets("Setting")
    Set ws2 = Sheets("R_Buy")
    Set ws3 = Sheets("R_Sell")
    Set ws4 = Sheets("S_Buy")
    Set ws5 = Sheets("S_Sell")
    Dim tbl As ListObject
    Dim tb2 As ListObject
    Dim tb3 As ListObject
    Dim tb4 As ListObject
    Dim tb5 As ListObject
    Set tbl = ws1.ListObjects("T_Setting")
    Set tb2 = ws2.ListObjects("T_R_Buy")
    Set tb3 = ws3.ListObjects("T_R_Sell")
    Set tb4 = ws4.ListObjects("T_S_Buy")
    Set tb5 = ws5.ListObjects("T_S_Sell")
    Dim newrow1 As ListRow
    Dim newrow2 As ListRow
    Dim newrow3 As ListRow
    Dim newrow4 As ListRow
    Dim newrow5 As ListRow

    MyValue = InputBox("Add To Table, this cannot be undone")

    'check if user clicked Cancel button and, if appropriate, execute statements
    If StrPtr(MyValue) = 0 Then
        'display message box confirming that user clicked Cancel button
        MsgBox "You clicked the Cancel button"
        'check if user entered no input and, if appropriate, execute statements
    ElseIf MyValue = "" Then
        'display message box confirming that user entered no input
        MsgBox "There is no Text Input"
    Else
        Set newrow1 = tbl.ListRows.Add
        With newrow1
            .Range(1) = MyValue
        End With

        Set newrow2 = tb2.ListRows.Add
        With newrow2
            .Range(1) = MyValue
        End With

        Set newrow3 = tb3.ListRows.Add
        With newrow3
            .Range(1) = MyValue
        End With

        Set newrow4 = tb4.ListRows.Add
        With newrow4
            .Range(1) = MyValue
        End With

        Set newrow5 = tb5.ListRows.Add
        With newrow5
            .Range(1) = MyValue
        End With
    End If
    Application.ScreenUpdating = True
End Sub

Answer 1

That's an issue with Excel that it doesn't allow to edit tables in UserInterFaceOnly:=True mode. Unfortunately, the only workaround I've found is to unprotect before any table methods are applied and then reprotect after:

.Unprotect Password:=SHEET_PW 'unprotect sheet          
'edit table         
.Protect Password:=SHEET_PW, UserInterFaceOnly:=True 'reprotect 

Additionally I suggest the following improvement to shorten your code:

• Use arrays Dim tbl(1 To 5) instead of multiple variables tbl1, tbl2, tbl3, …
• Or better use an array to list your worksheet names only.
• Use more descriptive variable names (makes your life easier to maintain and read the code)
• If your table names are always T_ followed by the worksheet name you can easily generate them out of your worksheet name.
• Use a constant for your worksheet password SHEET_PW to have it stored in only one place (easier to change, prevents typos).
• Use loops to do repetitive things.

So we end up with:

Option Explicit

Const SHEET_PW As String = "Secret" 'global password for protecting worksheets

Public Sub AddDataToTableImproved()
    Dim AddValue As String
    AddValue = InputBox("Add To Table, this cannot be undone")

    If StrPtr(AddValue) = 0 Then 'cancel button
        MsgBox "You clicked the Cancel button"
        Exit Sub
    ElseIf AddValue = "" Then 'no input
        MsgBox "There is no Text Input"
        Exit Sub
    End If

    Dim NewRow As ListRow

    Dim SheetNameList() As Variant
    SheetNameList = Array("Setting", "R_Buy", "R_Sell", "S_Buy", "S_Sell")

    Dim SheetName As Variant
    For Each SheetName In SheetNameList
        With ThisWorkbook.Worksheets(SheetName)
            .Unprotect Password:=SHEET_PW 'unprotect sheet

            Set NewRow = .ListObjects("T_" & SheetName).ListRows.Add
            NewRow.Range(1) = AddValue

            .Protect Password:=SHEET_PW, UserInterFaceOnly:=True 'reprotect it
        End With
    Next SheetName
End Sub

Answer 2

A bit late to help the original OP but hopefully this will help other readers.

There is indeed an issue with the ListObject functionality when the worksheet is protected even if the UserInterFaceOnly flag is set to True.

However, we can still use the Range and Application functionality and we can actually work around most of the use cases with the exception of 2 edge cases:

1. We want to insert immediately after the header row AND the sheet is protected AND the headers are off (.ShowHeaders is False) - I don't think there is any solution to this but to be honest I wonder why would one have the headers off. Not to mention it's a really rare case to meet all 3 criterias.
2. The table has no rows AND the sheet is protected AND the headers are off. In this case the special 'insert' row cannot easily be turned into a 'listrow' but it can be done with a few column and row inserts - not worth the trouble though as this is potentially rare in real life use.

Here is the code that I came up with:

Option Explicit
Option Private Module

Private Const MODULE_NAME As String = "LibExcelListObjects"

'*******************************************************************************
'Adds rows to a ListObject and returns the corresponding added Range
'Parameters:
'   - tbl: the table to add rows to
'   - [rowsToAdd]: the number of rows to add. Default is 1
'   - [startRow]: the row index from where to start adding. Default is 0 in
'       which case the rows would be appended at the end of the table
'   - [doEntireSheetRow]:
'       * TRUE  - adds entire rows including left and right of the target table
'       * FALSE - adds rows only below the table bounds shifting down (default)
'Raises error:
'   -    5: if 'rowsToAdd' is less than 1
'   -    9: if 'startRow' is invalid
'   -   91: if 'tbl' is not set
'   - 1004: if adding rows failed due to worksheet being protected while the 
'           UserInterfaceOnly flag is set to False
'*******************************************************************************
Public Function AddListRows(ByVal tbl As ListObject _
                          , Optional ByVal rowsToAdd As Long = 1 _
                          , Optional ByVal startRow As Long = 0 _
                          , Optional ByVal doEntireSheetRow As Boolean = False _
) As Range
    Const fullMethodName As String = MODULE_NAME & ".AddListRows"
    Dim isSuccess As Boolean
    '
    If tbl Is Nothing Then
        Err.Raise 91, fullMethodName, "Table object not set"
    ElseIf startRow < 0 Or startRow > tbl.ListRows.Count + 1 Then
        Err.Raise 9, fullMethodName, "Invalid start row index"
    ElseIf rowsToAdd < 1 Then
        Err.Raise 5, fullMethodName, "Invalid number of rows to add"
    End If
    If startRow = 0 Then startRow = tbl.ListRows.Count + 1
    '
    If startRow = tbl.ListRows.Count + 1 Then
        isSuccess = AppendListRows(tbl, rowsToAdd, doEntireSheetRow)
    Else
        isSuccess = InsertListRows(tbl, rowsToAdd, startRow, doEntireSheetRow)
    End If
    If Not isSuccess Then
        If tbl.Parent.ProtectContents And Not tbl.Parent.ProtectionMode Then
            Err.Raise 1004, fullMethodName, "Parent sheet is macro protected"
        Else
            Err.Raise 5, fullMethodName, "Cannot append rows"
        End If
    End If
    Set AddListRows = tbl.ListRows(startRow).Range.Resize(RowSize:=rowsToAdd)
End Function

'*******************************************************************************
'Utility for 'AddListRows' method
'Inserts rows into a ListObject. Does not append!
'*******************************************************************************
Private Function InsertListRows(ByVal tbl As ListObject _
                              , ByVal rowsToInsert As Long _
                              , ByVal startRow As Long _
                              , ByVal doEntireSheetRow As Boolean) As Boolean
    Dim rngInsert As Range
    Dim fOrigin As XlInsertFormatOrigin: fOrigin = xlFormatFromLeftOrAbove
    Dim needsHeaders As Boolean
    '
    If startRow = 1 Then
        If Not tbl.ShowHeaders Then
            If tbl.Parent.ProtectContents Then
                Exit Function 'Not sure possible without headers
            Else
                needsHeaders = True
            End If
        End If
        fOrigin = xlFormatFromRightOrBelow
    End If
    '
    Set rngInsert = tbl.ListRows(startRow).Range.Resize(RowSize:=rowsToInsert)
    If doEntireSheetRow Then Set rngInsert = rngInsert.EntireRow
    '
    On Error Resume Next
    If needsHeaders Then tbl.ShowHeaders = True
    rngInsert.Insert xlShiftDown, fOrigin
    If needsHeaders Then tbl.ShowHeaders = False
    InsertListRows = (Err.Number = 0)
    On Error GoTo 0
End Function

'*******************************************************************************
'Utility for 'AddListRows' method
'Appends rows to the bottom of a ListObject. Does not insert!
'*******************************************************************************
Private Function AppendListRows(ByVal tbl As ListObject _
                              , ByVal rowsToAppend As Long _
                              , ByVal doEntireSheetRow As Boolean) As Boolean
    If tbl.ListRows.Count = 0 Then
        If Not UpgradeInsertRow(tbl) Then Exit Function
        If rowsToAppend = 1 Then
            AppendListRows = True
            Exit Function
        End If
        rowsToAppend = rowsToAppend - 1
    End If
    '
    Dim rngToAppend As Range
    Dim isProtected As Boolean: isProtected = tbl.Parent.ProtectContents
    '
    On Error GoTo ErrorHandler
    If isProtected And tbl.ShowTotals Then
        Set rngToAppend = tbl.TotalsRowRange
    ElseIf isProtected Then
        Set rngToAppend = AutoExpandOneRow(tbl)
    Else
        Set rngToAppend = tbl.Range.Rows(tbl.Range.Rows.Count + 1)
    End If
    '
    Set rngToAppend = rngToAppend.Resize(RowSize:=rowsToAppend)
    If doEntireSheetRow Then Set rngToAppend = rngToAppend.EntireRow
    rngToAppend.Insert xlShiftDown, xlFormatFromLeftOrAbove
    '
    If isProtected And tbl.ShowTotals Then 'Fix formatting
        tbl.ListRows(1).Range.Copy
        With tbl.ListRows(tbl.ListRows.Count - rowsToAppend + 1).Range
            .Resize(RowSize:=rowsToAppend).PasteSpecial xlPasteFormats
        End With
    ElseIf isProtected Then 'Delete the autoExpand row
        tbl.ListRows(tbl.ListRows.Count).Range.Delete xlShiftUp
    Else 'Resize table
        tbl.Resize tbl.Range.Resize(tbl.Range.Rows.Count + rowsToAppend)
    End If
    AppendListRows = True
Exit Function
ErrorHandler:
    AppendListRows = False
End Function

'*******************************************************************************
'Utility for 'AppendListRows' method
'Transforms the Insert row into a usable ListRow
'*******************************************************************************
Private Function UpgradeInsertRow(ByVal tbl As ListObject) As Boolean
    If tbl.InsertRowRange Is Nothing Then Exit Function
    If tbl.Parent.ProtectContents And Not tbl.ShowHeaders Then
        Exit Function 'Not implemented - can be done using a few inserts
    Else
        Dim needsHeaders As Boolean: needsHeaders = Not tbl.ShowHeaders
        '
        If needsHeaders Then tbl.ShowHeaders = True
        tbl.InsertRowRange.Insert xlShiftDown, xlFormatFromLeftOrAbove
        If needsHeaders Then tbl.ShowHeaders = False
    End If
    UpgradeInsertRow = True
End Function

'*******************************************************************************
'Utility for 'AppendListRows' method
'Adds one row via auto expand if the worksheet is protected and totals are off
'*******************************************************************************
Private Function AutoExpandOneRow(ByVal tbl As ListObject) As Range
    If Not tbl.Parent.ProtectContents Then Exit Function
    If tbl.ShowTotals Then Exit Function
    '
    Dim ac As AutoCorrect: Set ac = Application.AutoCorrect
    Dim isAutoExpand As Boolean: isAutoExpand = ac.AutoExpandListRange
    Dim tempRow As Range: Set tempRow = tbl.Range.Rows(tbl.Range.Rows.Count + 1)
    '
    If Not isAutoExpand Then ac.AutoExpandListRange = True
    tempRow.Insert xlShiftDown, xlFormatFromLeftOrAbove
    Set AutoExpandOneRow = tempRow.Offset(-1, 0)
    Const arbitraryValue As Long = 1 'Must not be Empty/Null/""
    AutoExpandOneRow.Value2 = arbitraryValue 'AutoExpand is triggered
    If Not isAutoExpand Then ac.AutoExpandListRange = False 'Revert if needed
End Function

Assuming tbl is a variable holding the table, we can use the above like this:

AddListRows tbl             'Adds 1 row at the end
AddListRows tbl, 5          'Adds 5 rows at the end
AddListRows tbl, 3, 2       'Inserts 3 rows at index 2
AddListRows tbl, 1, 3, True 'Insert one row at index 3 but for the whole sheet

As long as the UserInterfaceOnly flag is set to True the above will work except the 2 edge cases I mentioned at the beginning of the answer. Of course, the operation would fail if there is another ListObject immediately below the table we want to insert into but that would fail anyway even if the sheet was unprotected.

One nice advantage is that the AddListRows method above returns the range that was inserted so that it can be used to write data immediately after the rows were added.