Cut and paste rows to new sheet based on different criteria in Column A I have a "working sheet" that contains 15000+ rows. In column A is an identifier for that row. There are over 20 different identifiers i.e 9W, AM, AV, BG, CY, HJ etc. etc.

My current code looks for each row on "Working Sheet" that has 9W in column A, cuts and pastes that row into a sheet called 9W. Once finished it moves to AM, finds am in Column A, cuts and pastes each row into a sheet called AM. Process repeats until all Identifiers have been done.

Here is a sample of the current code that I have created with my limited knowledge:

Sub Test()

'Do 9W

    Dim sht1 As Worksheet, sht2 As Worksheet
    Dim i As Long

    Set sht1 = ThisWorkbook.Worksheets("Working Sheet")
    Set sht2 = ThisWorkbook.Worksheets("9W")

    For i = 2 To sht1.Cells(sht1.Rows.Count, "A").End(xlUp).Row
        If sht1.Range("A" &amp; i).Value = "9W" Then
            sht1.Range("A" &amp; i).EntireRow.Cut sht2.Range("A" &amp; 
 sht2.Cells(sht2.Rows.Count, "A").End(xlUp).Row + 1)
        End If
    Next i

'Do AM

Dim sht3 As Worksheet, sht4 As Worksheet
Dim i1 As Long

Set sht3 = ThisWorkbook.Worksheets("Working Sheet")
Set sht4 = ThisWorkbook.Worksheets("AM")

For i1 = 2 To sht3.Cells(sht3.Rows.Count, "A").End(xlUp).Row
    If sht3.Range("A" &amp; i1).Value = "AM" Then
        sht3.Range("A" &amp; i1).EntireRow.Cut sht4.Range("A" &amp; 
sht4.Cells(sht4.Rows.Count, "A").End(xlUp).Row + 1)
    End If
Next i1

'DO AV

Dim sht5 As Worksheet, sht6 As Worksheet
Dim i2 As Long

Set sht5 = ThisWorkbook.Worksheets("Working Sheet")
Set sht6 = ThisWorkbook.Worksheets("AV")

For i2 = 2 To sht5.Cells(sht5.Rows.Count, "A").End(xlUp).Row
    If sht5.Range("A" &amp; i2).Value = "AV" Then
        sht5.Range("A" &amp; i2).EntireRow.Cut sht6.Range("A" &amp; 
sht6.Cells(sht6.Rows.Count, "A").End(xlUp).Row + 1)
    End If
Next i2

'DO BG

Dim sht7 As Worksheet, sht8 As Worksheet
Dim i3 As Long

Set sht7 = ThisWorkbook.Worksheets("Working Sheet")
Set sht8 = ThisWorkbook.Worksheets("BG")

For i3 = 2 To sht7.Cells(sht7.Rows.Count, "A").End(xlUp).Row
    If sht7.Range("A" &amp; i3).Value = "BG" Then
        sht7.Range("A" &amp; i3).EntireRow.Cut sht8.Range("A" &amp; 
    sht8.Cells(sht8.Rows.Count, "A").End(xlUp).Row + 1)
    End If
Next i3

End Sub
As long as all the rows in your working sheet have a valid identifier, you can simplify this process a lot by looking at each row and looking up the Sheet you're supposed to copy the row to.

This allows you to write a single loop instead of a loop for each ID there is:

Dim source As Worksheet
Dim target As Worksheet
Dim targetRow As Long

Set source = ThisWorkbook.Worksheets("Working Sheet")
' As long as there is a row to cut and paste
Do While source.Cells("A2").Value &lt;&gt; vbNullString
  ' select where the row is supposed to go
  Set target = ThisWorkbook.Worksheets(source.Cells("A2").Value)
  targetRow = target.Cells(target.Rows.Count, "A").End(xlUp).Row + 1
  ' and transfer it using copy &amp; delete
  With source.Range("A2").EntireRow
    .Copy target.Range("A" &amp; targetRow)
    .Delete xlShiftUp
  End With
Loop


Of course if that's not the case, this simplification still applies: Iterate the rows of the worksheet once and only Copy&amp;Delete the rows where the identifier matches one of the allowed identifiers.

If deleting the rows from the working sheet is not correct, or you don't want to move every row, you will need to iterate using a For Loop.