自动复制并在最后一个已填充的单元格下插入一行

Question

我已经为这个问题苦苦挣扎了一段时间了，我会尽我所能解释它。

我有一个活动表，其行号不断增加。每行都有一些必须存在的属性和隐藏单元格。所以我的问题是这样的：

当我来到行号（例如 100）并且表格已满时，我想在该行下输入一个具有与前一行相同属性的新行。

我设法在网上找到了一些代码并将它们合并成一个可运行的代码，但其中存在很多问题。代码如下：

Private Sub Workbook_Open()

Sub BlankLine()

    Dim Col As Variant
    Dim BlankRows As Long
    Dim LastRow As Long
    Dim R As Long
    Dim StartRow As Long

        Col = "C"
        StartRow = 123
        BlankRows = 1

            LastRow = Cells(Rows.Count, Col).End(xlUp).Row

            Application.ScreenUpdating = False

            With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If IsEmpty(.Cells(R, Col)) = False Then
.Cells(R + 1, Col).EntireRow.Copy
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
Range("A1").ClearOutline
End If
Next R
End With
Application.ScreenUpdating = True
End Sub

因此，事情是这样的：当您打开 Excel 时，它会立即搜索行号 123 之后单元格 C 中有任何内容的行，并将下一个空行复制到当前行之后。这里的问题是，每次我打开 Excel 时，它都会这样做，并复制一份又一份的副本。

我需要它如何发生：当您打开 Excel 时，代码处于活动状态，当您填充行号 124 时，复制行 125 并将其插入到行 124 下方，并以行 124 结束。现在将代码移动到行号 125，当此行在单元格 C 中有数据时，复制行 126 并将其移动到 125 下方，然后停止，依此类推...

这个想法是让表格中的行主动增加并复制数据，这样当表格填满时您不必手动执行此操作。

抱歉解释得太长了，我希望有一个解决方案。

先感谢您。

Answer 1

您需要将代码从Workbook_Open()事件中移出Worksheet_Change()事件

还要确保Option Explicit在所有模块中使用

将其放在 Sheet VBA 模块中。仅当 C 列中的单元格更新时才会触发

---

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge = 1 Then   'Check that only 1 cell is being edited
        If Len(Target) > 0 Then     'Make sure the cell is not empty
            With Target
                If .Row > 1 And .Column = 3 Then    'Exclude Header row, and act on col 3
                    OptimizeApp True
                    MovePropRow Target
                    OptimizeApp False
                End If
            End With
        End If
    End If
End Sub

Private Sub MovePropRow(ByVal Target As Range)
    Dim ws As Worksheet:    Set ws = Target.Parent
    Dim lr As Long:         lr = Target.Row
    Dim lrProp As Long:     lrProp = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row

    If lrProp = lr Then
        ws.Range(ws.Cells(lr, "D"), ws.Cells(lr, "I")).Copy
        ws.Cells(lr + 1, "D").PasteSpecial xlPasteAll
        ws.Range(ws.Cells(lr, "D"), ws.Cells(lr, "I")).Clear
        Target.Select
    End If
End Sub

Private Sub OptimizeApp(ByVal speedUp As Boolean)
    Application.Calculation = IIf(speedUp, xlCalculationManual, xlCalculationAutomatic)
    Application.ScreenUpdating = Not speedUp
    Application.DisplayAlerts = Not speedUp
    Application.EnableEvents = Not speedUp
End Sub

---

测试Sheet3-Before

测试Sheet3-After (typing "x" in Cell "C10")