We start out with a function is_it_red that returns true if any cell in a row
has red font.

We loop down the rows, looking for Truth. If we find Truth, we copy the
entire row and paste it in another worksheet and bump the paste counter:

Function is_it_red(i As Long) As Boolean
is_it_red = False
For j = 1 To Columns.Count
If Cells(i, j).Font.ColorIndex = 3 Then
is_it_red = True
Exit Function
End If
Next
End Function


Sub colorcopier()
Dim i As Long
k = 1
Set r = ActiveSheet.UsedRange
nLastRow = r.Rows.Count + r.Row - 1
For i = 1 To nLastRow
If is_it_red(i) Then
Set rc = Cells(i, 1).EntireRow
Set rd = Sheets("Summary").Cells(k, 1)
rc.Copy rd
k = k + 1
End If
Next
End Sub


--
Gary''s Student - gsnu200753


"ryguy7272" wrote:

Still stuck on a problem from a few days ago. I am trying to identify,
select, and copy all data in any row (copy the entire row) if a cells has any
red text in it. Then I want to move these items to a new sheet, lets call
it €œSummary Sheet€�.
Earlier in the week, I was playing with two concepts; so far I have been
unable to get either one working. Id appreciate any help.

Concept#1
Sub Select_Red_Fonts()
Dim c As Range, SearchRange As Range, cell As Range, redFonts As Range, x
Set SearchRange = Cells.SpecialCells(xlCellTypeConstants)
For Each c In SearchRange
If cell.Font.ColorIndex = 3 Then
c.EntireRow.Select
If x = 1 Then
Set redFonts = Union(redFonts, cell)
Else
Set redFonts = cell
x = 1
End If
End If
Next c
c.EntireRow.Select
redFonts.Select

Worksheets.Add.Name = "Summary"
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
End Sub


Concept#2
Sub Select_Red_Fonts()
Dim c As Range, SearchRange As Range, cell As Range, redFonts As Range, x
Dim rw As Long
Set SearchRange = Cells.SpecialCells(xlCellTypeConstants)
For Each c In SearchRange
If cell.Font.ColorIndex = 3 Then
c.EntireRow.Select
Worksheets("Summary").Cells(rw, 1).Value = cell.Value
rw = rw + 1
End If
Next
End Sub

Thanks,
Ryan--



--
RyGuy