Cutting/Pasting Rows based on content PT 2

None at all, I'm afraid... I tested it out and it worked fine, including the row that didn't move for you. If the reason comes to me I'll let you know, but hopefully one of the good people who hang around on this forum (who are, I must say, an exceptionally bright bunch) might have a clue because right now I'm baffled, sorry.


C

For some reason, occasionally the For...Next loop was skipping from B2 to B4 without checking B3 - I haven't a clue why, as when I rearranged the rows in random order it didn't do it every time. But changing the Cut to Copy and then clearing the values in the row seems to solve it:

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

Got there in the end...


C

Yeah, it copies the row then clears the cells - same effect as cutting, just an extra step


C