another method
this is currently set for yellow
Sub IfYellow()
Dim MyRange, Cell As Range
Dim wsname, MySheetNameTest As String
Dim j, x, RowCrnt As Integer
Application.ScreenUpdating = False
RowCrnt = Sheet1.Cells(Rows.Count, "Q").End(xlUp).Row
For x = 1 To RowCrnt
If Sheet1.Range("Q" & x).Interior.Color = 65535 Then 'change this to the correct colour
' Calc last row number
j = Sheet2.Cells(Rows.Count, "Q").End(xlUp).Row + 1
Sheet2.Range("A" & j & ":Q" & j).Value = Sheet1.Range("A" & x & ":Q" & x).Value
Sheet1.Rows(x).Delete
x = x - 1
End If
Next
Application.ScreenUpdating = True
End Sub
Bookmarks