VBA将行插入特定表格的底部并将所有单元格向下移动答案

【问题标题】：VBA Insert Row to bottom of specific table and shift all cells downVBA将行插入特定表格的底部并将所有单元格向下移动
【发布时间】：2021-09-02 11:52:03
【问题描述】：

我有一个包含多个选项卡和每个选项卡上的多个表格的电子表格。我想添加一个按钮，在表格底部添加一行并将工作表向下移动，以便表格不会进入下面的表格。我使用了在堆栈上其他地方找到的通用代码来添加一行，然后将其分配给一个按钮，它工作得很好，但想要包含一个函数来在表格下方的整个工作表中添加一行。我要在代码中添加什么来向下移动工作表？提前致谢！

Private Sub InsertRowsInTable(ByVal targetTableName As String)
    
    ' Ask user how many rows to ask
    Dim rowsToAdd As Variant
    rowsToAdd = InputBox("How many rows would you like to add?", "Insert Rows", 1)
    
    ' If user didn't input anything, default to 1
    If rowsToAdd = vbNullString Then rowsToAdd = 1
    
    Dim targetTable As ListObject
    Set targetTable = Range(targetTableName).ListObject
    
    ' Resize the table to add rows
    targetTable.Resize targetTable.Range.Resize(targetTable.Range.Rows.Count + rowsToAdd)
        
End Sub```

【问题讨论】：

嗨。表格有一种方法可以在表格的底部添加一行（默认情况下在底部），这会将表格下方的所有单元格向下移动。试试targetTable.ListRows.Add 见docs.microsoft.com/en-us/office/vba/api/… 和docs.microsoft.com/en-us/office/vba/api/excel.listrows.add
使用AlwaysInsert 参数选择是否希望单元格始终移动或仅在下面的单元格不为空白时才移动

标签： excel vba

【解决方案1】：

您可以通过两种方式做到这一点，简单的方式或困难的方式！

' easy way
Dim i As Integer
For i = 1 To rowsToAdd
    targetTable.ListRows.Add AlwaysInsert:=True
Next i

' hard way
Dim rng As Range: Set rng = targetTable.ListRows(targetTable.ListRows.Count).Range.Resize(rowsToAdd).Offset(1, 0)
rng.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

【讨论】：

【解决方案2】：

向 Excel 表格添加行

快速修复

Private Sub InsertRowsInTable(ByVal targetTableName As String)
    
    ' Ask user how many rows to ask
    Dim RowsToAdd As Variant
    RowsToAdd = InputBox("How many rows would you like to add?", "Insert Rows", 1)
    
    ' If user didn't input anything, default to 1
    If RowsToAdd = vbNullString Then RowsToAdd = 1
    
    Dim tbl As ListObject: Set tbl = Range(targetTableName).ListObject
    
    Dim trg As Range: Set trg = tbl.Range
    Dim trCount As Long: trCount = trg.Rows.Count
    Dim rMax As Long: rMax = trg.Worksheet.Rows.Count - trCount - trg.Row + 1
    If RowsToAdd > rMax Then Exit Sub
    Dim irg As Range: Set irg = trg.Resize(RowsToAdd).Offset(trCount)
    
    Application.ScreenUpdating = False
    
    Dim CouldNotAdd As Boolean
    On Error GoTo CouldNotAddError
    irg.Insert xlDown
    On Error GoTo 0
    
    If Not CouldNotAdd Then
        tbl.Resize trg.Resize(trCount + RowsToAdd)
    End If
            
    Application.ScreenUpdating = True
            
    Exit Sub

CouldNotAddError:
    CouldNotAdd = True
    Resume Next
        
End Sub

使用Resize

这使用了更灵活的Application.InputBox，更广泛地涵盖了各种问题。

Sub AddRowsToTable()
    
    Const Title As String = "Insert Rows"
    Const msgNoRange As String = "Select a range."
    Const msgNoTable As String = "Select a range in a table."
    Const aiPrompt As String = "How many rows would you like to add?"
    Const aiDefault As Long = 1
    Const msgCanceled As String = "Canceled."
    Const msgOnlyDigits As String = "Only digits are allowed."
    Const msgZero As String = "No rows added (0)."
    
    ' Range (Selection)
    If TypeName(Selection) <> "Range" Then
        MsgBox msgNoRange, vbCritical, Title
        Exit Sub
    End If
    Dim srg As Range: Set srg = Selection
    
    ' Table
    Dim tbl As ListObject: Set tbl = srg.ListObject
    If tbl Is Nothing Then
        MsgBox msgNoTable, vbCritical, Title
        Exit Sub
    End If
    
    ' Application InputBox
    Dim RowsToAdd As Variant
    RowsToAdd = Application.InputBox(aiPrompt, Title, aiDefault, , , , , 1)
    Debug.Print TypeName(RowsToAdd), VarType(RowsToAdd)
    
    ' Canceled
    If VarType(RowsToAdd) = vbBoolean Then
    'If RowsToAdd = False Then ' this will include 0
        MsgBox msgCanceled, vbExclamation, Title
        Exit Sub
    End If
    ' Only Digits
    Dim rtaString As String: rtaString = CStr(RowsToAdd)
    Dim rtaLen As Long: rtaLen = Len(rtaString)
    Dim n As Long
    For n = 1 To rtaLen
        If Not Mid(rtaString, n, 1) Like "[0-9]" Then
            Exit For
        End If
    Next n
    If n <= rtaLen Then
        MsgBox msgOnlyDigits, vbCritical, Title
        Exit Sub
    End If
    ' Zero
    If RowsToAdd = 0 Then
        MsgBox msgZero, vbCritical, Title
        Exit Sub
    End If
    
    Dim trg As Range: Set trg = tbl.Range
    Dim trCount As Long: trCount = trg.Rows.Count
    Dim rMax As Long
    rMax = trg.Worksheet.Rows.Count - trCount - trg.Row + 1
    If RowsToAdd > rMax Then
        MsgBox "Not enough rows (worksheet)." & vbLf _
            & "Use a number between 1 and " & rMax & ".", vbCritical, Title
        Exit Sub
    End If
    Dim irg As Range: Set irg = trg.Resize(RowsToAdd).Offset(trCount)
    
    Application.ScreenUpdating = False
    
    Dim CouldNotAdd As Boolean
    On Error GoTo CouldNotAddError
    irg.Insert xlDown
    On Error GoTo 0
    
    If CouldNotAdd Then
        Application.ScreenUpdating = True
        MsgBox "Not enough rows (there is data below).", vbCritical, Title
    Else
        tbl.Resize trg.Resize(trCount + RowsToAdd)
        Application.ScreenUpdating = True
        If RowsToAdd = 1 Then
            MsgBox "Added one row to table '" _
                & tbl.Name & "'.", vbInformation, Title
        Else
            MsgBox "Added " & RowsToAdd & " rows to table '" _
                & tbl.Name & "'.", vbInformation, Title
        End If
    End If
    
    Exit Sub
    
CouldNotAddError:
    CouldNotAdd = True
    Resume Next

End Sub

使用ListRows

这是我最初的尝试，但是太慢了。我放弃了这个想法，因此并未涵盖所有问题（就像上面的高级解决方案一样）。

Sub AddRowsToTableSlow()
    
    Const Title As String = "Insert Rows"
    Const msgNoRange As String = "Select a range."
    Const msgNoTable As String = "Select a range in a table."
    Const aiPrompt As String = "How many rows would you like to add?"
    Const aiDefault As Long = 1
    Const msgCanceled As String = "Canceled."
    Const msgOnlyDigits As String = "Only digits are allowed."
    Const msgZero As String = "No rows added."
    Const aiMax As Long = 1000
    
    ' Range (Selection)
    If TypeName(Selection) <> "Range" Then
        MsgBox msgNoRange, vbCritical, Title
        Exit Sub
    End If
    Dim srg As Range: Set srg = Selection
    
    ' Table
    Dim tbl As ListObject: Set tbl = srg.ListObject
    If tbl Is Nothing Then
        MsgBox msgNoTable, vbCritical, Title
        Exit Sub
    End If
    
    ' Application InputBox
    Dim RowsToAdd As Variant
    RowsToAdd = Application.InputBox(aiPrompt, Title, aiDefault, , , , , 1)
    Debug.Print TypeName(RowsToAdd), VarType(RowsToAdd)
    
    ' Canceled
    If VarType(RowsToAdd) = vbBoolean Then
    'If RowsToAdd = False Then ' this will include 0
        MsgBox msgCanceled, vbExclamation, Title
        Exit Sub
    End If
    ' Only Digits
    Dim rtaString As String: rtaString = CStr(RowsToAdd)
    Dim rtaLen As Long: rtaLen = Len(rtaString)
    Dim n As Long
    For n = 1 To rtaLen
        If Not Mid(rtaString, n, 1) Like "[0-9]" Then
            Exit For
        End If
    Next n
    If n <= rtaLen Then
        MsgBox msgOnlyDigits, vbCritical, Title
        Exit Sub
    End If
    ' Zero
    If RowsToAdd = 0 Then
        MsgBox msgZero, vbCritical, Title
        Exit Sub
    End If
    ' Max
    If RowsToAdd > aiMax Then
        Dim msgMax As String
        msgMax = "It will take a while adding so many rows." & vbLf _
            & "Are you sure you want to add " & RowsToAdd & " rows?"
        Dim msg As Variant
        msg = MsgBox(msgMax, vbYesNo + vbExclamation, Title)
        If vbNo Then
            Exit Sub
        End If
    End If
    
    Application.ScreenUpdating = False
    
    Dim CouldNotAdd As Boolean
    On Error GoTo CouldNotAddError
    For n = 1 To RowsToAdd
        tbl.ListRows.Add
        If CouldNotAdd Then
            Exit For
        End If
    Next n
    On Error GoTo 0
    n = n - 1

    Application.ScreenUpdating = True

    If CouldNotAdd Then
        Select Case n
        Case 0
            MsgBox "No rows added.", vbExclamation, Title
        Case 1
            MsgBox "Only one row was added to table '" _
                & tbl.Name, vbExclamation, Title
        Case Else
            MsgBox "Only " & n & " rows were added to the table '" _
                & tbl.Name & "'.", vbExclamation, Title
        End Select
    Else
        If RowsToAdd = 1 Then
            MsgBox "Added one row to table '" & tbl.Name & "'.", _
                vbInformation, Title
        Else
            MsgBox "Added " & RowsToAdd & " rows to table '" _
                & tbl.Name & "'.", vbInformation, Title
        End If
    End If
    
    Exit Sub
    
CouldNotAddError:
    CouldNotAdd = True
    Resume Next

End Sub

【讨论】：

【解决方案3】：

感谢大家的回复！

我结合 Elio Fernandes 和 Vincent G 的建议解决了这个问题。

我在调整表格大小时添加了For rowinsert = 0 To rowsToAdd - 1。所以我最终得到的是

Private Sub InsertRowsInTable(ByVal targetTableName As String)
   
    ' Ask user how many rows to ask
    Dim rowsToAdd As Variant
    rowsToAdd = InputBox("How many rows would you like to add?", "Insert Rows", 1)
   
    ' If user didn't input anything, default to 1
    If rowsToAdd = vbNullString Then rowsToAdd = 1
   
    Dim targetTable As ListObject
    Set targetTable = Range(targetTableName).ListObject
   
    Dim rowinsert As Integer
   
    ' Resize the table to add rows
    For rowinsert = 0 To rowsToAdd - 1
        targetTable.Range.EntireRow(targetTable.Range.Rows.Count + 1).Insert
    Next
    targetTable.Resize targetTable.Range.Resize(targetTable.Range.Rows.Count + rowsToAdd) 
End Sub

然后我可以使用分配按钮

Public Sub InsertRowsInTable1()
    InsertRowsInTable "Table1"
End Sub

这让我可以在表格中添加行，然后将所有内容向下移动，这样表格就不会相互碰撞。

再次感谢大家的回复！

【讨论】：