How to access all red rows in a sheet?

Question

I have a sheet in which there is a big number of rows. Some of them are colored in red. Above each red row there are 6 blank rows in which i have to copy the red row and paste it 6 times, 1 time in each of the blank rows above it.

I cannot figure out a way to access the red rows in a sheet and paste its content in the 6 rows above it . If anyone has an idea i would really be happy!

Here is the code that colors the rows in red (after filtering):

    Sub FilterByAA()

Dim lastrow As Long

Sheets("Raw Data").Activate

lastrow = Cells(Rows.Count, 1).End(xlUp).Row

Range("A1:AT" & lastrow).Select

'Selection.AutoFilter Field:=2, Criteria1:="A6FC"
Selection.AutoFilter Field:=16, Criteria1:="AA", Operator:=xlFilterValues




Worksheets("Raw Data").UsedRange.Interior.ColorIndex = 3
Worksheets("Raw Data").Rows(1).EntireRow.Interior.ColorIndex = 2


End Sub

And here is the code that inserts 6 rows before each red row:

Sub InsertAA()
    Dim c As Range
    Set Rng = ActiveSheet.Range("P1:P7000")
    For dblCounter = Rng.Cells.Count To 1 Step -1
        Set c = Rng(dblCounter)
        If c.Value Like "AA" Then
        c.EntireRow.Insert
        c.EntireRow.Insert
        c.EntireRow.Insert
        c.EntireRow.Insert
        c.EntireRow.Insert
        c.EntireRow.Insert
    End If
    Next dblCounter
End Sub

Answer 1

You can try something like this

Private Sub Celine_N()

Dim LongRow     As Long

For LongRow = Cells(Rows.Count, 16).End(xlUp).Row To 2 Step -1    'Coulmn 16 is Column "P"

If Cells(LongRow, 16).Interior.ColorIndex = 3 Then

    Rows(LongRow).Copy
    Rows(LongRow - 1).PasteSpecial xlPasteValues    'Can be replaced using For...Next Loop
    Rows(LongRow - 2).PasteSpecial xlPasteValues
    Rows(LongRow - 3).PasteSpecial xlPasteValues
    Rows(LongRow - 4).PasteSpecial xlPasteValues
    Rows(LongRow - 5).PasteSpecial xlPasteValues
    Rows(LongRow - 6).PasteSpecial xlPasteValues
End If

Next

Application.CutCopyMode = False

End Sub

Answer 2

Combining both and streamlining:

Sub FilterAndInsert

application.screenupdating=false

Dim lastrow As Long, rgLoop As Range, rgRed As Range

With Sheets("Raw Data")

    lastrow = .Cells(Rows.Count, 1).End(xlUp).Row

    With .Range("A1:AT" & lastrow)
        .AutoFilter
        .AutoFilter Field:=16, Criteria1:="AA", Operator:=xlFilterValues
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Interior.ColorIndex = 3

        Set rgRed = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)

        .AutoFilter

    End With

    For Each rgLoop In rgRed.Areas
        rgLoop.Resize(6).EntireRow.Insert xlShiftDown
        rgLoop.Offset(-6).Resize(6).Value = rgLoop.Value
    Next rgLoop

End With

application.screenupdating=true

End Sub