Need this code to move multiple rows at once to a new sheet

Question

The code below moves a single row to a new sheet but i need it to move all of them. For example ill have 11-1, 11-2, 11-3, 12-1, 12-2, 12-3 etc and it needs to move all the 11s at once.

Sub Findandcut()
Dim rw As Long
Dim lastrow As Long

For rw = 1000 To 2 Step -1

    lastrow = Worksheets("Sheet2").UsedRange.Rows(Worksheets("Sheet2").UsedRange.Rows.Count).row
    With Worksheets("Sheet1")
        ' Check if "save" appears in the value anywhere.
        If .Cells(rw, 1).Value Like "*11*" Then
            ' Cut the value and then blank the source and shift up
            .Cells(rw, 2).EntireRow.Cut Destination:=Worksheets("Sheet2").Cells(lastrow, 1)
            '.Cells(rw, 2).EntireRow.Delete (xlUp)
        End If
    End With
Next
End Sub

Instead of a loop, use `AutoFilter` as shown [Here](https://stackoverflow.com/questions/11631363/how-to-copy-a-line-in-excel-using-a-specific-word-and-pasting-to-another-excel-s/11633207#11633207) to move all of them in 1 go... — Siddharth Rout, Jul 25 '19 at 19:05
If you want to move all of the rows at the same time, I suggest using a filter and then copy/paste using `SpecialCells(xlCellTypeVisible)` — GMalc, Jul 25 '19 at 19:07
Im very new to VBA, any idea on how to do that? and the auto filter is giving me the error: Subscript out of range — matt.auerbach, Jul 25 '19 at 19:19

AAA · Answer 1 · 2019-07-25T19:56:01.617

Rather than finding, copy and pasting for each cell, we first take the union of all the rows that match the given criterion, and then copy and paste just once. Afterwards, we can delete all those rows from Sheet1. This is both faster and more efficient:

Sub Findandcut()
Dim rw As Long, lastrow As Long, MySel As Range

With Worksheets("Sheet1")
    For rw = 1000 To 2 Step -1
        If .Cells(rw, 1).Value Like "*11*" Then
            If MySel Is Nothing Then
                Set MySel = .Cells(rw, 1).EntireRow
            Else
                Set MySel = Union(MySel, .Cells(rw, 1).EntireRow)
            End If
        End If
    Next rw
End With

With ThisWorkbook.Worksheets("Sheet2")
    lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
    If Not MySel Is Nothing Then
        MySel.Copy Destination:= .Cells(lastrow+1, 1)
        MySel.Delete
    End If
End With

End Sub

**1** Looping is definitely not recommended for such operation **2** Please try your code before suggesting :) `MySel.Cut` will not work with noncontigous ranges. — Siddharth Rout, Jul 25 '19 at 19:44
@SiddharthRout, I have amended this with code that works. Thank you. I find, gathering all the rows before cutting and pasting is much faster than individual operations — AAA, Jul 25 '19 at 19:51

Need this code to move multiple rows at once to a new sheet

1 Answers1