Move row based on cell color

[sameh_ag]

Hello
I made a macro to move entire row to the end of sheet based on cell color
Macro is working fine but if 2 or more consecutive rows meet the criteria it skips one, this is because if rows 2 &3 meet the criteria, after moving row 2, row 3 becomes 2 and is considered done
Thanks

Sub Test()
    
    Dim MR          As Excel.Range
    Dim rngCell     As Excel.Range
    Dim rngCount    As Long
    
    Dim iRow        As Long
    Dim ws          As Worksheet
    Set ws = Worksheets("Strip. & Other")
    
    Set MR = Sheets("Strip. & Other").Range("L1:L300")
    
    rngCount = 1
    
    For Each rngCell In MR
        
        If rngCell.DisplayFormat.Interior.Color = RGB(255, 192, 0) Then
            
            rngCell.Select
            ActiveCell.EntireRow.Cut
            iRow = ws.Range("B:B").Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
            
            Range("A" & iRow).Select
            
            Selection.Insert Shift:=xlDown
            
        Else: GoTo 1
            
        End If
1
    Next rngCell
    
End Sub

 

[sxhall]

Hi sameh_ag,

To do this you need to work through the list inreverse, from the bottom up. Below finds the last row and starts there and works up through hte list (-1 each time). This way the it captures rows with the same colour next to each other.

I have used colmn 'B' to find the last row as this is where you are searching to add the entries after this row.

Also, I've added in an additional step ! This will keep the entries in the order they are found if the sheet was worked through from the top down, example image 1 below. Delete this row if not needed. Example image 2 is with this row deleted.

Sub Reverse()

Dim LRow As Long
Dim RowCount As Long
Dim iRow As Long

With Sheets("Strip. & Other")
    
    LRow = Range("B" & Rows.Count).End(xlUp).Row '***Column B find last row
    AddRow = LRow + 1
        
        For RowCount = LRow To 2 Step -1
        
            If .Cells(RowCount, 12).DisplayFormat.Interior.Color = RGB(255, 192, 0) Then
            
            Range("A" & RowCount).EntireRow.Cut
            Range("A" & AddRow).Select
            Selection.Insert Shift:=xlDown
            AddRow = AddRow - 1 '*** Additional step - Delete this if not needed
            
            End If
            
        Next RowCount
        
    End With

End Sub

Test Started With...
Rows 7-8 and 12-13 are together.

Example image 1...
Entries run in order found as if list was worked from the top.

Example image 2...
Entries are in the order found working from the bottom up.

 

[sameh_ag]

works perfectly, thank you so much sxhall
The order option is excellent, was reluctant to ask for it
Thanks again

 

[jolivanes]

I know you have the perfect solution from sxhall but just for the heck of it. Without looping.
Change references as required.

Sub Move_Colored()
Dim lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
   With ActiveSheet
      If .AutoFilterMode Then .AutoFilterMode = False
         .Range("A1:A" & lr).AutoFilter 1, RGB(255, 0, 0), xlFilterCellColor
         With .Range("A2:A" & lr).SpecialCells(xlVisible)
         .Copy ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1)
         .EntireRow.Delete Shift:=xlUp
      End With
      .AutoFilterMode = False
   End With
Application.ScreenUpdating = True
End Sub

An easy way to get the RGB color of a cell is to:
Select the colored cell - right click - Format Cells - Fill - More Colors - Custom - Set "Color Model" to RGB.