Tengo una hoja de trabajo de datos que tiene cuatro columnas. Quiero que la hoja de cálculo agregue 3 filas después de cada grupo según la columna D. La columna D tiene el departamento para las transacciones. Todas las transacciones del departamento se enumeran en una fila. Entonces Excel solo necesita encontrar el cambio en el departamento e ingresar tres filas después de esa sección.

He probado este código que encontré aquí. Pone una fila después de cada línea en la que ve el departamento.

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
1
Doupis 3 oct. 2019 a las 22:51

1 respuesta

La mejor respuesta

Este código insertará 3 filas entre grupos de valores (incluso valores únicos). No es necesario filtrar los datos. Recorrerá Column D, probará la celda sobre la celda actual y, si no es el mismo valor, insertará 3 filas entre ellas. Es posible que primero deba ordenar los datos, según lo que desee.

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
0
GMalc 3 oct. 2019 a las 20:43