时间戳

首页 > 解决方案 > 将 ListRow 添加到受保护工作表的表中

excel - 将 ListRow 添加到受保护工作表的表中

问题描述

当工作表受到保护时，我想将数据添加到每个工作表中每个表的最后一行。

我在 ThisWorkbook 中有这段代码来保护工作表

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

以及添加数据的以下代码。它抛出

错误 1004 “应用程序定义或对象定义错误”

在Set newrow1 = tbl.ListRows.Add工作表受到保护时。

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

标签： excelvba

解决方案

帮助原始 OP 有点晚了，但希望这会帮助其他读者。

ListObject即使UserInterFaceOnly标志设置为 ，当工作表受到保护时，功能确实存在问题True。

但是，我们仍然可以使用RangeandApplication功能，并且我们实际上可以解决大多数用例，但 2 个边缘情况除外：

  1. 我们想在标题行之后立即插入，并且工作表受到保护并且标题关闭（.ShowHeaders 为假） - 我认为没有任何解决方案，但老实说，我想知道为什么要关闭标题. 更不用说满足所有 3 个标准的情况非常罕见。
  2. 该表没有行并且工作表受到保护并且标题已关闭。在这种情况下，特殊的“插入”行不能轻易地变成“列表行”，但可以通过一些列和行插入来完成——尽管这在现实生活中可能很少见，但不值得麻烦。

这是我想出的代码：

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

假设tbl是一个保存表的变量，我们可以像这样使用上面的：

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

只要将UserInterfaceOnly标志设置为True上述内容，除了我在答案开头提到的 2 个边缘情况外，它都可以工作。当然，如果在我们要插入的表的正下方有另一个 ListObject，则操作将失败，但即使工作表未受保护，该操作也会失败。

一个很好的优点是AddListRows上面的方法返回插入的范围，以便在添加行后立即使用它来写入数据。

推荐阅读