copy row based on color

[hshayh0rn]

I would like to look at all of the rows in column A and determine if the
color = "6" and if the color index is 6 then copy that entire row to another
sheet. I believe I have code that will check for the color but I'm not sure
how to then copy the row to the other sheet. Also, I either need to amend the
destination sheet or replace the contents of the sheet all together. I can
not have duplicates on the dest sheet. Here is what I have so far:

Sub testme()

Dim myCell As Range
Dim newWks As Worksheet
Dim curWks As Worksheet
Dim LastRow As Long
Dim LastCol As Long
Dim iRow As Long
Dim iCol As Long
Dim oRow As Long
Dim rng As Range
Dim myColorIndex As Long

Set curWks = Worksheets("2006 Scheduled Activities")
Set newWks = Worksheets("sheet3")

myColorIndex = 6
oRow = 1
With curWks
With .UsedRange
LastRow = .Rows(.Rows.Count).Row
End With

For iRow = 1 To LastRow
If .Cells(iRow, "A").Interior.ColorIndex = myColorIndex Then
'
'need the code that would go here to copy the entire row to sheet3 is the
row matches color index 6
'

End If
'End If
Next iRow
End With
End Sub

 

[Ron de Bruin]

Hi hshayh0rn

Try this (untested)

Sub testme2()

Dim myCell As Range
Dim newWks As Worksheet
Dim curWks As Worksheet
Dim LastRow As Long
Dim LastCol As Long
Dim iRow As Long
Dim iCol As Long
Dim oRow As Long
Dim rng As Range
Dim myColorIndex As Long

Set curWks = Worksheets("2006 Scheduled Activities")
Set newWks = Worksheets("sheet3")

myColorIndex = 6
oRow = 1
With curWks
With .UsedRange
LastRow = .Rows(.Rows.Count).Row
End With

For iRow = 1 To LastRow
If IsError(.Cells(iRow, "A").Value) Then
'Do nothing, This avoid a error if there is a error in the cell

ElseIf .Cells(iRow, "A").Interior.ColorIndex = myColorIndex Then
If rng Is Nothing Then
Set rng = .Cells(iRow, "A")
Else
Set rng = Application.Union(rng, .Cells(iRow, "A"))
End If
End If

Next iRow
End With

If Not rng Is Nothing Then rng.EntireRow.Copy newWks.Range("A1")

End Sub