I have a spreadsheet that is about 3000x24. Extensive Search and replace has
changed cell color for cells whose content matches search criteria (red
cell). there
are now about 400 colored cells spread throughout the worksheet. I want to
select each row that has a colored cell and place it in a new worksheet. Any
suggestions how to automate this?
--
Phantom Researcher

--
Phantom Researcher

Sub RedRows()
Dim rng As Range, red As Range
Dim x As Long, y As Long
Dim n As Long, m As Long
With ActiveSheet
'start the union with the first empty row below.
Set red = .UsedRange.Resize(1).Offset(.UsedRange.Rows.Count)
Set rng = .UsedRange.Cells(1)
n = .UsedRange.Rows.Count - 1
m = .UsedRange.Columns.Count - 1
End With
With rng
For x = 0 To n
For y = 0 To m
If .Offset(x, y).Interior.ColorIndex = 3 Then
Set red = Union(red, .Offset(x, 0).Resize(1, m + 1))
Exit For
End If
Next
Next
End With
'clear the empty row from the union
Set red = Intersect(red, ActiveSheet.UsedRange)
'copy the union to sheet2
red.Copy activeworkbook.Worksheets(2).Cells(1)

End Sub


keepITcool

< email : keepitcool chello nl (with @ and .)
< homepage: http://members.chello.nl/keepitcool


?B?RWR3YXJk?= wrote in message
:

I have a spreadsheet that is about 3000x24. Extensive Search and
replace has changed cell color for cells whose content matches search
criteria (red cell). there
are now about 400 colored cells spread throughout the worksheet. I
want to select each row that has a colored cell and place it in a new
worksheet. Any suggestions how to automate this?