Sub copy_if_matches_criteria()
Dim wshSource As Worksheet, wshDest As Worksheet
Dim rngCell As Range
If Intersect([b:b], ActiveSheet.UsedRange) Is Nothing Then Exit Sub
Set wshSource = ActiveSheet
Set wshDest = Sheets.Add(before:=ActiveSheet)
wshDest.Name = "TS"
wshSource.Select
For Each rngCell In Intersect([b:b], Range(Rows(2), Cells.SpecialCells(xlCellTypeLastCell)))
If (rngCell.Value * 1 > 300 And rngCell.Value * 1 < 399) Or _
(rngCell.Value * 1 > 1100 And rngCell.Value * 1 < 1199) Or _
(rngCell.Value * 1 > 4018 And rngCell.Value * 1 <= 4028) Or _
rngCell.Value * 1 = 4011 Then rngCell.EntireRow.Copy _
wshDest.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next
wshSource.[1:1].Copy wshDest.[a1]
wshDest.Select
End Sub
Bookmarks