Copy row to a new sheet if a cell in the row meets criteria

[lebowski]

Hi, I am at a loss as to how to do the following in VBA:

I want to copy all rows from the current worksheet to a new worksheet (created and named by the script) if the cell in column W has a red (255, 0, 0) background.

Is anyone able to help? Thanks.

[YasserKhalil]

May be something like that

Sub Test()
    Dim Cell As Range
    Dim WS As Worksheet
    Dim LR As Long
    Application.ScreenUpdating = False
        For Each WS In Worksheets
            Application.DisplayAlerts = False
                If WS.Name = "Result" Then WS.Delete
            Application.DisplayAlerts = True
        Next WS
        
        Worksheets.Add After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = "Result"
        Sheets("Sheet1").Activate
        
        For Each Cell In Range("W1:W20")
            If Cell.Interior.Color = RGB(255, 0, 0) Then
                Cell.EntireRow.Copy
                LR = Sheets("Result").Range("A" & Rows.Count).End(xlUp).Row + 1
                If IsEmpty(Sheets("Result").Range("A1")) Then Sheets("Result").Range("A1").PasteSpecial xlPasteAll: GoTo 1
                Sheets("Result").Range("A" & LR).PasteSpecial xlPasteAll
            End If
1        Next Cell
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

[lebowski]

Fantastic, works perfectly. Thank you so much.

[YasserKhalil]

You're welcome . thanks for the feedback

[SamT]

Lebowski, Here's another way to look at YasserKhalil's fine code. The main difference is the use of a ColorIndex, which does not change, although the color of that index can easily be changed on the Color Tab of the Tools >> Options menu. The Default value of Interior.ColorIndex(3) is RGB(255, 0, 0), as is the Constant vbRed. The other minor changes are mostly due to personal style preferences.

Sub Test()
Dim Cel As Range
Dim PasteHere As Range
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  OnError ResumeNext
  Worksheets("Result").Delete
   
  Worksheets.Add After:=Sheets(Sheets.Count)
  Sheets(Sheets.Count).Name = "Result"
      
    For Each Cel In Sheets("Sheet1").UsedRange.Columns("W")
      If Cel.Interior.ColorIndex = 3 Then
        Cel.EntireRow.Copy
        Set PasteHere = Sheets("Result").Range("A" & Rows.Count).End(xlUp)
        If PasteHere.Row = 1 Then
          PasteHere.PasteSpecial.xlPasteAll
        Else
          PasteHere.Offset(1, 0).PasteSpecial.xlPasteAll
        End If
      End If
     Next Cel
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Run the TestColors Macro in this book

[YasserKhalil]

Mr. SamT
Thanks for the modifications ... You are right about ColorIndex property.
But when tested your code it doesn't work as expected!!

[SamT]

What did you expect?

(Select empty space below with mouse to see answer)
A1 should have value = 3.
A2 should have no value.

With any Cell, Right Click >> Format >> Patterns

Then on Excel Menu >> Tools >> Options >> Color Tab, Click third color down in second column from left (Red). Then; Click "Modify" button and see RGB Value.

When satisfied, on Color Tab, click Reset Button.

[YasserKhalil]

I'm woking on office 2007 .. I can not get your steps Mr SamT?
Did you mean VBE or Excel itself?? I didn't find Color Tab...

[SamT]

All in excel, except the code. I assume you have seen the code in Sheet1.

I Excel 2002 there is a Tools menu on the MenuBar. In the Tool menu is the (Excel) Options dialog where we can set many Excel Options including the actual hues, shades, and tints of each Cell color choice. Those are the 56 colors available to Format cells with.
I changed the standards colors. I set ColorIndex 3 to a green color and some other ColorIndex to RGB(255, 0, 2). Then I formatted the cells with those colors.

See this link for HowTo in 2007+ :http://support.microsoft.com/kb/288412

Here's a sub that shows all the colors of all the ColorIndexes

Sub showColorIndexNums()
    Dim i As Integer, n As Integer
    n = 0
    Worksheets.Add before:=Sheets(1)
    [A1].Value = "Color"
    [B1].Value = "Index Number"
    ActiveSheet.Name = "ColorIndex"
    For i = 2 To 58
        Range("A" & i).Interior.ColorIndex = n
        Range("B" & i).Value = n
        n = n + 1
    Next i
    ActiveSheet.[B:B].EntireColumn.AutoFit
End Sub

[YasserKhalil]

Thanks a lot Mr SamT
I could get it now .. and thank you for this nice code

[lebowski]

Thanks SamT, really useful to see an alternate approach again with minimal and clean code. Have much to learn.

[SamT]