Cutting/Pasting Rows based on content PT 2

I posted a question about cutting and pasting rows based on content yesterday, and I used the code that was provided and it worked great.

NOW I need to do it again, but this time there is a lot more criteria that I need to remove (cut and paste into another worksheet).

I would like to focus ONLY on column B (titled PAYCL).

Essentially, this is what I would like my macro to do:

If the number in column B : "is between 0300 and 0399", "is between 1100 and 1199", "is between 4018 and 4028", is equal to "4011", or is equal to "4028" then cut the entire row and paste it into a new worksheet within that workbook and title it "TS"

did that make sense?

Attached is an example of a spreadsheet that I have to perform this task on DAILY.

Thanks everyone, I think this will be my last post for today (you can all breathe a sigh of relief...haha)

much respect,
-Laura

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

OOPS. I need it to CUT the rows and then paste to a new sheet. This one was only COPYING them. Would I just change it from
"wshSource.[1:1].Copy wshDest.[a1]
wshDest.Select"

to

wshSource.[1:1].CUT wshDest.[a1]
wshDest.Select

?

No, that's just copying the first row - the column titles - to the new sheet. Change "rngCell.EntireRow.Copy _" to "rngCell.EntireRow.Cut _" and put


Code:
intersect([b:b],activesheet.usedrange).specialcells(xlcelltypeblanks).entirerow.delete
before the line:
wshDest.Select

and you're laughing!

C

Col,

right now, i'm ripping my hair out. It worked great, except for ONE teeny tiny row that didn't get cut and pasted over. I've tried to think of EVERY reason for that ONE stupid row to have stayed behind. I'm baffled....

here's the code I used:

PHP Code: 

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 <= 4025) Or _
            (rngCell.Value * 1 = 4028) Or _
            (rngCell.Value * 1 = 305) Or _
            rngCell.Value * 1 = 4011 Then rngCell.EntireRow.Cut _
            wshDest.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    Next
    
    wshSource.[1:1].Copy wshDest.[a1]
    Intersect([b:b], ActiveSheet.UsedRange).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    wshDest.Select
    
End Sub 


and I attached the spreadsheet with that ONE stinking row that was left behind.

any suggestions?

you're the best.