Добавить новую строку при изменении значения ячейки

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

Я использовал один и тот же код три раза, с разными столбцами, но я думаю, что он не работает из-за новых (пустых) строк, введенных с первого запуска. Я написал это как три отдельных Subs .

 Sub LineTestCODE() Dim lRow As Long For lRow = Cells(Cells.Rows.Count, "C").End(xlUp).Row To 2 Step -1 If Cells(lRow, "C") <> Cells(lRow - 1, "C") Then Rows(lRow).EntireRow.Insert Next lRow End Sub Sub LineTestENHANCEMENT() Dim lRow2 As Long For lRow2 = Cells(Cells.Rows.Count, "D").End(xlUp).Row To 2 Step -1 If Cells(lRow2, "D") <> Cells(lRow2 - 1, "D") Then Rows(lRow2).EntireRow.Insert Next lRow2 End Sub Sub LineTestZONE() Dim lRow3 As Long For lRow3 = Cells(Cells.Rows.Count, "G").End(xlUp).Row To 2 Step -1 If Cells(lRow3, "G") <> Cells(lRow3 - 1, "G") Then Rows(lRow3).EntireRow.Insert Next lRow3 End Sub 

Я не совсем уверен, как вы хотите добавить свои строки. Похоже, вы хотите протестировать измененную ячейку, и если она не соответствует ячейке выше, добавьте строку. Я думаю, также возможно, что вы хотите добавить одну строку для каждой пары парных пар в столбцах. Вы увидите оба кода ниже – возьмите свой выбор.

Я помещаю этот код в событие Sheet_Change, но вы можете поместить его в модуль и вызвать его из этого события, если хотите. Вы увидите, что я отключил события, это может быть проблемой с вашим кодом.

Эта процедура не проверяет, если кто-то вставил значения (например, Target.Cells.Count> 1). Возможно, вы захотите обработать возможность того, что Target является несколькими ячейками.

 For Each item in Target.Cells ..//.. Next 

может работать для вас.

 Private Sub Worksheet_Change(ByVal Target As Range) Dim MyColumns As Range ' Define the value columns we're interested in If MyColumns Is Nothing Then Set MyColumns = Union(Columns("C"), _ Columns("D"), _ Columns("G")) End If ' If you just want to add one row for a non-matching change in one of the three columns changes If Not Intersect(Target, MyColumns) Is Nothing Then If Target.Row > 1 Then If Target.Offset(-1).Value <> Target.Value Then Application.EnableEvents = False Target.Offset(1).EntireRow.Insert Application.EnableEvents = True End If End If End If ' If you want to add one row for each non-matching cell value in the three columns Dim cell As Range If Not Intersect(Target, MyColumns) Is Nothing Then If Target.Row > 1 Then For Each cell In Intersect(MyColumns, Target.EntireRow).Cells If cell.Offset(-1).Value <> cell.Value Then Application.EnableEvents = False cell.Offset(1).EntireRow.Insert Application.EnableEvents = True End If Next End If End If End Sub 
Interesting Posts

Как перенести данные из таблицы Excel в плоский файл без заголовков столбцов?

Проникновение рекурсивного дерева

Excel VBA с использованием SUMPRODUCT и COUNTIFS – проблема скорости

Python, странное значение при попытке вычисления ошибки линейной регрессии

Вернуть номер строки или true или false или значение, если условие выполнено – VBA Excel

Маленький макрос VBA работает очень медленно

Не удалось закрыть Excel даже после выпуска ресурсов

Проверка пустых ячеек с помощью OpenPyXl

Range.ArrayFormula, вызывающий ошибку в конкретных случаях

Чтобы сохранить отдельный рабочий лист в Excel в исходную папку с желаемым именем

Столбец таблицы разделен по значению на другие столбцы и его значения

Автофильтр Перебирать критерии с другого листа

Составить SQL-запрос в запросе соединения OBDC

Приложение C # прекращает работу при записи данных в Excel

Формула для отображения формата номера и текста вместе

Давайте будем гением компьютера.