Вставьте одну строку между группами на основе критериев в столбце

Question

У меня есть лист данных с четырьмя столбцами. Я хочу, чтобы электронная таблица добавляла 3 строки после каждой группы на основе столбца D. В столбце D есть отдел для транзакций. Все операции отдела перечислены в строке. Поэтому Excel нужно просто найти изменения в отделе и ввести три строки после этого раздела.

Я попробовал этот код, который нашел здесь. Он ставит строку после каждой строки, в которой видит отдел.

Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("IMPORT-WIP") 'better define by name: ThisWorkbook.Worksheets("MySheet")

    Dim LastRow_f As Long
    LastRow_f = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row

    ws.Range("A1:D" & LastRow_f).AutoFilter Field:=12, Criteria1:="HR DEPARTMENT"

    Dim FilteredData As Range
    Set FilteredData = ws.Range("D2:D" & LastRow_f).SpecialCells(xlCellTypeVisible)

    Dim iArea As Long
    Dim iRow As Long
    For iArea = FilteredData.Areas.Count To 1 Step -1 'loop from last to first area
        For iRow = FilteredData.Areas(iArea).Rows.Count To 1 Step -1 'loop from last row to first row in each area
            With FilteredData.Areas(iArea).Rows(iRow) '<-- this represents the current row we are in the loop
                .Offset(RowOffset:=1).EntireRow.Insert Shift:=xlDown
                .Offset(RowOffset:=1).EntireRow.Interior.Color = RGB(192, 192, 192)
            End With
        Next iRow
    Next iArea

    'remove filters
    ws.Range("A1:D" & LastRow_f).AutoFilter

Answer 1

Этот код вставит 3 строки между группами значений (даже уникальными значениями). Данные не нужно фильтровать. Он перебирает Column D, проверяет ячейку над текущей ячейкой и, если не совпадает со значением, вставит между ними 3 строки. Возможно, вам придется сначала отсортировать данные, в зависимости от того, что вы хотите.

Sub InsertRowsBetweenGroups()
Dim ws As Worksheet, lr As Long, i As Long

Set ws = ThisWorkbook.Sheets("Sheet1") 'Change as needed

lr = ws.Cells(ws.Rows.Count, 4).End(xlUp).Row

    For i = lr - 1 To 2 Step -1
        If Cells(i, "D") <> Cells(i - 1, "D") Then
            Cells(i, "D").Resize(3).EntireRow.Insert Shift:=xlDown
        End If
    Next i
End Sub