If Font.ColorIndex = 3, Copy Entire Row and Paste to New Sheet
 

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

If Font.ColorIndex = 3, Copy Entire Row and Paste to New Sheet
 

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

If Font.ColorIndex = 3, Copy Entire Row and Paste to New Sheet
 

hi
i copied your code and try to run it. crashed left and right. i knew it would.
why?
concept 1....
cell has not been set. value = nothing
redfonts has not been set. value = nothing
x has not been assigned a value
workbook.add in wrong place
selection not selected.
c.entirerow.select outside of loop

trying to stick as close to your code as possible.....
i did modify some, added some and commented out sections that didn't seem to
have any purpose......
Sub Select_Red_Fonts()
Dim c As Range, SearchRange As Range, cell As Range, redFonts As Range, x
Set SearchRange = Cells.SpecialCells(xlCellTypeConstants)
Worksheets.Add.Name = "Summary"
Sheets("sheet1").Activate
For Each c In SearchRange
If c.Font.ColorIndex = 3 Then
c.EntireRow.Copy
Sheets("summary").Activate
Range("A65000").End(xlUp).Offset(1, 0).PasteSpecial _
Paste:=xlPasteValues
Sheets("sheet1").Activate
'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

concept2
cell has not been set. value = nothing
rw has not been assigned a value
other problems too.
i didn't rewrite this one.

If you are useing variable, you have to assign then a value or set them
somehow.
and remember. code executes one line after another. be sure the sequences
are in the correct order. copy something before you paste. create the
worksheet before you paste to it.

regards
FSt1

"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

If Font.ColorIndex = 3, Copy Entire Row and Paste to New Sheet
 

Thanks for the insight GS, and thanks to you FSt1!

Cordially,
Ryan-


--
RyGuy


"FSt1" wrote:

hi
i copied your code and try to run it. crashed left and right. i knew it would.
why?
concept 1....
cell has not been set. value = nothing
redfonts has not been set. value = nothing
x has not been assigned a value
workbook.add in wrong place
selection not selected.
c.entirerow.select outside of loop

trying to stick as close to your code as possible.....
i did modify some, added some and commented out sections that didn't seem to
have any purpose......
Sub Select_Red_Fonts()
Dim c As Range, SearchRange As Range, cell As Range, redFonts As Range, x
Set SearchRange = Cells.SpecialCells(xlCellTypeConstants)
Worksheets.Add.Name = "Summary"
Sheets("sheet1").Activate
For Each c In SearchRange
If c.Font.ColorIndex = 3 Then
c.EntireRow.Copy
Sheets("summary").Activate
Range("A65000").End(xlUp).Offset(1, 0).PasteSpecial _
Paste:=xlPasteValues
Sheets("sheet1").Activate
'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

concept2
cell has not been set. value = nothing
rw has not been assigned a value
other problems too.
i didn't rewrite this one.

If you are useing variable, you have to assign then a value or set them
somehow.
and remember. code executes one line after another. be sure the sequences
are in the correct order. copy something before you paste. create the
worksheet before you paste to it.

regards
FSt1

"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