Simplify code copy based on condition
 

Hello,

I would like help modifying my code for copying rows with certain conditions
to a new sheet. I currently have code with a range extending to 5000 but the
rows may vary from day to day. I like to it to look at the last row based on
data existing in row 'F". Any help that you provide would be greatly
appreciated.
This is what I now have:

Option Explicit
Sub CopyRowsWithConFormat()
Dim SearchRange As Range
Dim EachCell As Range
Dim CopyRange As Range
Dim nSh As Worksheet

Application.ScreenUpdating = False
Columns("N:N").Hidden = False

Set SearchRange = ActiveSheet.Range("C1:Q5000")
For Each EachCell In SearchRange
If EachCell.Font.ColorIndex = 3 Or EachCell.Interior.ColorIndex
= 3 _
Or EachCell.Font.Bold Or EachCell.Interior.ColorIndex = 6 _
Or EachCell.Interior.ColorIndex = 8 Or
EachCell.Interior.ColorIndex = 33 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
Columns("A:A").ColumnWidth = 5.43
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 = 4.57
Columns("O:O").ColumnWidth = 5.86
Columns("P:P").ColumnWidth = 5.29
Columns("Q:Q").ColumnWidth = 16.86
Columns("N:N").Hidden = True
Columns("G:G").Select
With Selection
.WrapText = True
End With
NameZM
Columns("R:R").Hidden = True
UpdateHeader
Range("P1").Select
Application.ScreenUpdating = True
End Sub

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

Simplify code copy based on condition
 

Hi,

Replace this

Set SearchRange = ActiveSheet.Range("C1:Q5000")

with this

lastrow = Cells(Rows.Count, "F").End(xlUp).Row
Set SearchRange = ActiveSheet.Range("C1:Q" & lastrow)

because you have declared option explicit you must Dim Lastrow

Dim lastrow As Long

Mike

"DavidH56" wrote:

Hello,

I would like help modifying my code for copying rows with certain conditions
to a new sheet. I currently have code with a range extending to 5000 but the
rows may vary from day to day. I like to it to look at the last row based on
data existing in row 'F". Any help that you provide would be greatly
appreciated.
This is what I now have:

Option Explicit
Sub CopyRowsWithConFormat()
Dim SearchRange As Range
Dim EachCell As Range
Dim CopyRange As Range
Dim nSh As Worksheet

Application.ScreenUpdating = False
Columns("N:N").Hidden = False

Set SearchRange = ActiveSheet.Range("C1:Q5000")
For Each EachCell In SearchRange
If EachCell.Font.ColorIndex = 3 Or EachCell.Interior.ColorIndex
= 3 _
Or EachCell.Font.Bold Or EachCell.Interior.ColorIndex = 6 _
Or EachCell.Interior.ColorIndex = 8 Or
EachCell.Interior.ColorIndex = 33 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
Columns("A:A").ColumnWidth = 5.43
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 = 4.57
Columns("O:O").ColumnWidth = 5.86
Columns("P:P").ColumnWidth = 5.29
Columns("Q:Q").ColumnWidth = 16.86
Columns("N:N").Hidden = True
Columns("G:G").Select
With Selection
.WrapText = True
End With
NameZM
Columns("R:R").Hidden = True
UpdateHeader
Range("P1").Select
Application.ScreenUpdating = True
End Sub

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

Simplify code copy based on condition
 

Thanks for you quick response Mike. It works beautifully.
--
By persisting in your path, though you forfeit the little, you gain the
great.



"Mike H" wrote:

Hi,

Replace this

Set SearchRange = ActiveSheet.Range("C1:Q5000")

with this

lastrow = Cells(Rows.Count, "F").End(xlUp).Row
Set SearchRange = ActiveSheet.Range("C1:Q" & lastrow)

because you have declared option explicit you must Dim Lastrow

Dim lastrow As Long

Mike

"DavidH56" wrote:

Hello,

I would like help modifying my code for copying rows with certain conditions
to a new sheet. I currently have code with a range extending to 5000 but the
rows may vary from day to day. I like to it to look at the last row based on
data existing in row 'F". Any help that you provide would be greatly
appreciated.
This is what I now have:

Option Explicit
Sub CopyRowsWithConFormat()
Dim SearchRange As Range
Dim EachCell As Range
Dim CopyRange As Range
Dim nSh As Worksheet

Application.ScreenUpdating = False
Columns("N:N").Hidden = False

Set SearchRange = ActiveSheet.Range("C1:Q5000")
For Each EachCell In SearchRange
If EachCell.Font.ColorIndex = 3 Or EachCell.Interior.ColorIndex
= 3 _
Or EachCell.Font.Bold Or EachCell.Interior.ColorIndex = 6 _
Or EachCell.Interior.ColorIndex = 8 Or
EachCell.Interior.ColorIndex = 33 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
Columns("A:A").ColumnWidth = 5.43
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 = 4.57
Columns("O:O").ColumnWidth = 5.86
Columns("P:P").ColumnWidth = 5.29
Columns("Q:Q").ColumnWidth = 16.86
Columns("N:N").Hidden = True
Columns("G:G").Select
With Selection
.WrapText = True
End With
NameZM
Columns("R:R").Hidden = True
UpdateHeader
Range("P1").Select
Application.ScreenUpdating = True
End Sub

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