根据列中的条件在组之间插入一行

Question

我有一个包含四列的数据工作表。我希望电子表格在基于D列的每个组之后添加3行。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