Hello,

Fortunately I've been able to get a lot of support which has helped me from
this group. Currently I have a problem copying rows where there may be a
combination of font colors. I use the following code to copy red text only.
I'm still learning about vba and I find it absolutely amazing. I think you
experts really display expertise in assisting beginners like me. Now I would
appreciate any assistance for copying rows whereas cells having a combination
of red and black text. Any assistance you provide will be greatly
appreciated.

Sub CopyRowsWithRed()
Dim SearchRange As Range
Dim EachCell As Range
Dim CopyRange As Range
Dim nSh As Worksheet

Application.ScreenUpdating = False
Set SearchRange = ActiveSheet.Range("C1:Q5000")
For Each EachCell In SearchRange
If EachCell.Font.ColorIndex = 3 Or EachCell.Interior.ColorIndex
= 6 _
Or EachCell.Font.Bold Then
If Not CopyRange Is Nothing Then
Set CopyRange = Union(CopyRange, EachCell.EntireRow)
Else
Set CopyRange = EachCell.EntireRow
End If
End If
Next EachCell
CopyRange.Copy
Set nSh = Worksheets.Add
nSh.Range("A1").PasteSpecial xlPasteAll
Columns("A:o").Select
Columns("A:o").EntireColumn.AutoFit
Cells.Select
With Selection.Font
.Name = "Arial"
.Size = 8
End With
Range("A1").Select
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.Orientation = xlLandscape
.PrintGridlines = True
.PrintTitleColumns = ""
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.LeftFooter = "FOUO"
.CenterHeader = "CRRRENT UPDATES"
.RightHeader = "&D"

Columns("A:A").ColumnWidth = 4.71
Columns("B:B").ColumnWidth = 3.86
Columns("C:C").ColumnWidth = 4.01
Columns("D:D").ColumnWidth = 4.86
Columns("E:E").ColumnWidth = 4.86
Columns("F:F").ColumnWidth = 12.57
Columns("G:G").ColumnWidth = 18.29
Columns("H:H").ColumnWidth = 9.29
Columns("I:I").ColumnWidth = 8.43
Columns("J:J").ColumnWidth = 8.43
Columns("K:K").ColumnWidth = 8.43
Columns("L:L").ColumnWidth = 4.29
Columns("M:M").ColumnWidth = 4.57
Columns("N:N").ColumnWidth = 5.29
Columns("O:O").ColumnWidth = 5.86
Columns("P:P").ColumnWidth = 16.86
End With
Columns("G:G").Select
With Selection
.WrapText = True
End With
Range("P1").Select
Application.ScreenUpdating = True
Columns("Q:Q").ColumnWidth = 11.29
End Sub

--
By persisting in your path, though you forfeit the little, you gain the
great.

David,

replace

If EachCell.Font.ColorIndex = 3 Or EachCell.Interior.ColorIndex = 6 _
Or EachCell.Font.Bold Then
with
If EachCell.Font.ColorIndex = 3 Or EachCell.Font.ColorIndex = 1 Then

and it will select red and black. Note that black isn't the same as automatic.
or xlnone

Mike

"DavidH56" wrote:

Hello,

Fortunately I've been able to get a lot of support which has helped me from
this group. Currently I have a problem copying rows where there may be a
combination of font colors. I use the following code to copy red text only.
I'm still learning about vba and I find it absolutely amazing. I think you
experts really display expertise in assisting beginners like me. Now I would
appreciate any assistance for copying rows whereas cells having a combination
of red and black text. Any assistance you provide will be greatly
appreciated.

Sub CopyRowsWithRed()
Dim SearchRange As Range
Dim EachCell As Range
Dim CopyRange As Range
Dim nSh As Worksheet

Application.ScreenUpdating = False
Set SearchRange = ActiveSheet.Range("C1:Q5000")
For Each EachCell In SearchRange
If EachCell.Font.ColorIndex = 3 Or EachCell.Interior.ColorIndex
= 6 _
Or EachCell.Font.Bold Then
If Not CopyRange Is Nothing Then
Set CopyRange = Union(CopyRange, EachCell.EntireRow)
Else
Set CopyRange = EachCell.EntireRow
End If
End If
Next EachCell
CopyRange.Copy
Set nSh = Worksheets.Add
nSh.Range("A1").PasteSpecial xlPasteAll
Columns("A:o").Select
Columns("A:o").EntireColumn.AutoFit
Cells.Select
With Selection.Font
.Name = "Arial"
.Size = 8
End With
Range("A1").Select
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.Orientation = xlLandscape
.PrintGridlines = True
.PrintTitleColumns = ""
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.LeftFooter = "FOUO"
.CenterHeader = "CRRRENT UPDATES"
.RightHeader = "&D"

Columns("A:A").ColumnWidth = 4.71
Columns("B:B").ColumnWidth = 3.86
Columns("C:C").ColumnWidth = 4.01
Columns("D:D").ColumnWidth = 4.86
Columns("E:E").ColumnWidth = 4.86
Columns("F:F").ColumnWidth = 12.57
Columns("G:G").ColumnWidth = 18.29
Columns("H:H").ColumnWidth = 9.29
Columns("I:I").ColumnWidth = 8.43
Columns("J:J").ColumnWidth = 8.43
Columns("K:K").ColumnWidth = 8.43
Columns("L:L").ColumnWidth = 4.29
Columns("M:M").ColumnWidth = 4.57
Columns("N:N").ColumnWidth = 5.29
Columns("O:O").ColumnWidth = 5.86
Columns("P:P").ColumnWidth = 16.86
End With
Columns("G:G").Select
With Selection
.WrapText = True
End With
Range("P1").Select
Application.ScreenUpdating = True
Columns("Q:Q").ColumnWidth = 11.29
End Sub

--
By persisting in your path, though you forfeit the little, you gain the
great.

Thanks for your response Mike. I tried your suggestion but was unable to copy
cells with combination black and red font colors. Actually, I still need the
bold and color index of red to copy those rows as well. What I wanted was to
also include when one cell has font colors of red and black together. I just
wanted to this as well.

--
By persisting in your path, though you forfeit the little, you gain the
great.



"Mike H" wrote:

David,

replace

If EachCell.Font.ColorIndex = 3 Or EachCell.Interior.ColorIndex = 6 _
Or EachCell.Font.Bold Then
with
If EachCell.Font.ColorIndex = 3 Or EachCell.Font.ColorIndex = 1 Then

and it will select red and black. Note that black isn't the same as automatic.
or xlnone

Mike

"DavidH56" wrote:

Hello,

Fortunately I've been able to get a lot of support which has helped me from
this group. Currently I have a problem copying rows where there may be a
combination of font colors. I use the following code to copy red text only.
I'm still learning about vba and I find it absolutely amazing. I think you
experts really display expertise in assisting beginners like me. Now I would
appreciate any assistance for copying rows whereas cells having a combination
of red and black text. Any assistance you provide will be greatly
appreciated.

Sub CopyRowsWithRed()
Dim SearchRange As Range
Dim EachCell As Range
Dim CopyRange As Range
Dim nSh As Worksheet

Application.ScreenUpdating = False
Set SearchRange = ActiveSheet.Range("C1:Q5000")
For Each EachCell In SearchRange
If EachCell.Font.ColorIndex = 3 Or EachCell.Interior.ColorIndex
= 6 _
Or EachCell.Font.Bold Then
If Not CopyRange Is Nothing Then
Set CopyRange = Union(CopyRange, EachCell.EntireRow)
Else
Set CopyRange = EachCell.EntireRow
End If
End If
Next EachCell
CopyRange.Copy
Set nSh = Worksheets.Add
nSh.Range("A1").PasteSpecial xlPasteAll
Columns("A:o").Select
Columns("A:o").EntireColumn.AutoFit
Cells.Select
With Selection.Font
.Name = "Arial"
.Size = 8
End With
Range("A1").Select
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.Orientation = xlLandscape
.PrintGridlines = True
.PrintTitleColumns = ""
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.LeftFooter = "FOUO"
.CenterHeader = "CRRRENT UPDATES"
.RightHeader = "&D"

Columns("A:A").ColumnWidth = 4.71
Columns("B:B").ColumnWidth = 3.86
Columns("C:C").ColumnWidth = 4.01
Columns("D:D").ColumnWidth = 4.86
Columns("E:E").ColumnWidth = 4.86
Columns("F:F").ColumnWidth = 12.57
Columns("G:G").ColumnWidth = 18.29
Columns("H:H").ColumnWidth = 9.29
Columns("I:I").ColumnWidth = 8.43
Columns("J:J").ColumnWidth = 8.43
Columns("K:K").ColumnWidth = 8.43
Columns("L:L").ColumnWidth = 4.29
Columns("M:M").ColumnWidth = 4.57
Columns("N:N").ColumnWidth = 5.29
Columns("O:O").ColumnWidth = 5.86
Columns("P:P").ColumnWidth = 16.86
End With
Columns("G:G").Select
With Selection
.WrapText = True
End With
Range("P1").Select
Application.ScreenUpdating = True
Columns("Q:Q").ColumnWidth = 11.29
End Sub

--
By persisting in your path, though you forfeit the little, you gain the
great.