D
DavidH56
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").Select
Columns("A").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").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").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
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").Select
Columns("A").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").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").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