Автоматически копировать и вставлять строку под последнюю заполненную ячейку

Question

Я уже давно борюсь с этой проблемой и постараюсь объяснить ее как можно лучше.

У меня есть активная таблица, число строк которой постоянно увеличивается. Каждая строка имеет некоторые свойства и скрытые ячейки, которые должны быть там. Итак, моя проблема заключается в следующем:

Когда я прихожу к номеру строки ex.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")