Excel VBA：在表中插入行并填充上面一行中的所有内容

I have a problem with a little bit of VBA code I pulled together and I just can't find an answer somewhere else. I have a table named TableOPQuery which has over 40 columns and over 10k rows.

我有一个问题，我把一些VBA代码拉到一起，我在其他地方找不到答案。我有一个名为TableOPQuery的表，它有40多列和超过10k行。

There is a column called SPLITS where the user will write a value x (integer). If that value is greater than 1 then a row will be inserted under the row where the user wrote the value, because the purpose of that value is to add rows and copy everything the original row had (values, formulas, format) to make the same amount of rows specificied by the user including the original one, so it woul be like "x - 1".

有一个名为SPLITS的列，用户将在其中写入值x（整数）。如果该值大于1，那么将在用户写入值的行下插入一行，因为该值的目的是添加行并复制原始行具有的所有内容（值，公式，格式）以使用户指定的行数相同，包括原始行，因此它将像“x - 1”。

Here is an example, because I propably couldn't explain it good enough:

这是一个例子，因为我可能无法解释它足够好：

Order   Provider       Amount   Type    Splits  Shipped
23     Shady company    10000   Whole   1   
30     That company     2000    Split   2   
*30     That company     2000   Split*
35     This company     420     Whole       

So, you see, in row 1 (order 23), the user wrote 1, so no rows will be inserted. But, in row 2 (order 30), the user wrote 2. So one more row will be inserted, copying everything from the row above (the one where the user inserted 2), to make 2 rows identical to each other.

所以，你看，在第1行（第23行）中，用户写了1，因此不会插入任何行。但是，在第2行（第30行）中，用户写了2.因此，将插入另一行，从上面的行（用户插入2的行）中复制所有内容，使2行彼此相同。

I managed to piece toger this code that helps me in inserting whatever amount of rows the user wants, but for some reason I can not make it fill down from the original row where the user wrote the value and I want it to clear the contents in the SPLIT row to not trigger the code again.

我设法编写了这个代码来帮助我插入用户想要的任何数量的行，但由于某种原因，我不能让它从用户写入值的原始行填充，我希望它清除内容SPLIT行不再触发代码。

I am stumped now, because the normal filldown fuction doesn't work. I can insert rows, but I cant copy and fill down everything the row above has, and I can't clear the column SPLITS either.

我现在很难过，因为正常的填充功能不起作用。我可以插入行，但我无法复制并填写上面的行所有内容，我也无法清除列SPLITS。

Private Sub Worksheet_Change(ByVal Target As range)
    Dim KeyCells As range
    Dim xValue As Integer
    Dim tbl As ListObject
    Dim tRows As Long
    Dim tCols As Long
    Dim originCell As String

    'I call a fuction that will give me the position of the column that has SPLITS in it, searching a predefined row (5:5). I know this is unnecessary but this is the best I could do because the column SPLITS might change of position (add/delete columns)
    col = ColumnNumberByHeader("Splits")

   'I use this to get the amount of rows the table has mostly
    Set tbl = ActiveSheet.ListObjects("TableOPQuery")
    With tbl.DataBodyRange
        tRows = .Rows.Count
        tCols = .Columns.Count
    End With

   'An If to get a range using the a predefined start row (5), the col I got earlier, and the amount of rows the table has. If I get 0 as col is because the column does not exist
    If col <> 0 Then
        Set KeyCells = range(Cells(5, col), Cells(tRows, col))
    Else
        Cancel = True
        MsgBox "Check that column SPLITS exist"
        Exit Sub
    End If

    'Here is where the level noob magic happens. Rows start getting inserted if a value in the range I got in KeyCells happens
    If Not Application.Intersect(KeyCells, range(Target.Address)) Is Nothing Then
        'If the value is not numeric then nothing will run
        If IsNumeric(Target) Then
            'If the target is greater than 1 then the amount of Target.Value minus 1 of rows will be inserted under the row where the change occurred
            If Target.Value > 1 Then 
                originCell = Target.Address       
                xValue = Target.Value - 1
                MsgBox "Cell " & Target.Address & " has changed."
                'A loop to insert the rows, I use - 4 because the Target.Address is of the whole worksheet, and not the table itself.
                For i = 1 To Target.Value - 1 Step 1
                    tbl.ListRows.Add (range(Target.Address).row - 4)
                    'Filling down into the inserted rows from the row of the originCell (where the user inserted the value)
                    range(originCell).EntireRow.FillDown
                Next i
            End If
        End If
    End If
End Sub

1 个解决方案

#1

Assumption

• Sheet name (that contains the table): Sheet1
• 工作表名称（包含表格）：Sheet1
• Table Name: TableOPQuery
• 表名：TableOPQuery
• Corresponding column header: Splits
• 对应的列标题：拆分

Try this:

尝试这个：

Private Sub Worksheet_Change(ByVal Target As Range)

    If ActiveSheet.Name = "Sheet1" Then
        Application.ScreenUpdating = False
        Application.EnableEvents = False

        Dim tbl As ListObject
        Dim rng As Range
        Dim SCI As Integer 'Specific Column Index
        Dim CN As String 'Column Name

        CN = "Splits"
        Set tbl = Worksheets("Sheet1").ListObjects("TableOPQuery")
        Set rng = Range("TableOPQuery[#All]")
        SCI = Application.WorksheetFunction.Match(CN, Range("TableOPQuery[#Headers]"), 0)

        If Cells(rng.Row + rng.Rows.Count - 1, rng.Column + SCI - 1) > 1 Then
            tbl.ListRows.Add
            Range(Cells(rng.Row + rng.Rows.Count, rng.Column).Address & ":" & _
                Cells(rng.Row + rng.Rows.Count, rng.Column + rng.Columns.Count - 1).Address).FillDown
        End If

    End If

    Application.EnableEvents = True
End Sub