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

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

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

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

当我来到行号(例如 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 下方,然后停止,依此类推...

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

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

先感谢您。

答案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

测试表3之前

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

测试表3之后

相关内容