Как получить доступ ко всем красным рядам на листе?

Question

У меня есть лист, в котором есть большое количество строк.Некоторые из них окрашены в красный цвет.Над каждой красной строкой есть 6 пустых строк, в которые я должен скопировать красную строку и вставить ее 6 раз, по 1 разу в каждой из пустых строк над ней.

Я не могу найти способ получить доступ к красным строкам на листе и вставить его содержимое в 6 строк над ним.Если у кого-то есть идея, я был бы очень рад!

Вот код, который окрашивает строки в красный цвет (после фильтрации):

    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

А вот код, который вставляет 6 строкперед каждым красным рядом:

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

Объединение и оптимизация:

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

Answer 2

Вы можете попробовать что-то вроде этого

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