Cut and paste rows to new sheet based on different criteria in Column A

Question

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" & i).Value = "9W" Then
 sht1.Range("A" & i).EntireRow.Cut sht2.Range("A" & 
 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" & i1).Value = "AM" Then
 sht3.Range("A" & i1).EntireRow.Cut sht4.Range("A" & 
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" & i2).Value = "AV" Then
 sht5.Range("A" & i2).EntireRow.Cut sht6.Range("A" & 
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" & i3).Value = "BG" Then
 sht7.Range("A" & i3).EntireRow.Cut sht8.Range("A" & 
 sht8.Cells(sht8.Rows.Count, "A").End(xlUp).Row + 1)
 End If
Next i3
End Sub

Answer 1

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 <> 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 & delete
 With source.Range("A2").EntireRow
 .Copy target.Range("A" & 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&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.

• Mathieu Guindon: While...Wend should be Do While...Loop, and not involving the clipboard (assuming only the values are needed) would be even faster.
• Vogel612: thanks for the syntax fix. I have no idea how to fix that clipboard issue, though....
• Pettsy100: Thanks , however the Code stops at the Do While line. I changed the "A2" to 1,2 (Row, Column) and it cut / pasted the 1st row once correctly, then stopped.. any ideas
• Ryan Wildry: I don't think this code shifts cells up after cutting. So the first iteration would work, but then it will always be blank.
• Vogel612: @RyanWildry I think I fixed that now :)

Answer 2

If you are only concerned with moving values (e.g. formats aren't important) from the Working Sheet to all other sheets, this approach should be significantly faster than copy and pasting the cells.

This method starts by sorting the cells first so like cells are grouped together. The method will build up a range as it iterates, and when it encounters a new value it will dump the built up Range to the corresponding sheet. In my brief testing, this was able to complete moving 20,000 cells to three different sheets in less than 1 second.

Public Sub MoveData()
 On Error GoTo ErrorHandler:
 Dim LastRow As Long
 Dim Cell As Range
 Dim SearchRange As Range
 Dim FilterRange As Range
 Dim PreviousValue As String
 Dim JoinedRange As Range
 Dim FirstIteration As Boolean
 Dim RangeToJoin As Range
 Dim SourceSheet As Worksheet
 Dim MyTimer As Long
 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
 MyTimer = Timer
 Set SourceSheet = ThisWorkbook.Worksheets("Sheet1")
 'Sort the data together so it is grouped
 With SourceSheet
 LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
 LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
 Set SearchRange = .Range(.Cells(1, 1), .Cells(LastRow, 1)) 'Search only in column A, where sheet names are
 Set FilterRange = .Range(.Cells(1, 1), .Cells(LastRow, LastColumn)) 'Area to sort
 .Sort.SortFields.Add Key:=SearchRange, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
 End With
 FirstIteration = True
 For Each Cell In SearchRange
 'Don't process changes for the first row
 If Not FirstIteration Then
 If PreviousValue = Cell.Value2 And Len(Cell.Value2) > 0 Then
 Set RangeToJoin = SourceSheet.Range(SourceSheet.Cells(Cell.Row, 1), SourceSheet.Cells(Cell.Row, LastColumn))
 If JoinedRange Is Nothing Then
 Set JoinedRange = RangeToJoin
 Else
 Set JoinedRange = Union(JoinedRange, RangeToJoin)
 End If
 ElseIf Len(PreviousValue) > 0 Then
 With ThisWorkbook.Sheets(PreviousValue)
 LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
 .Range(.Cells(LastRow, 1), .Cells(JoinedRange.Rows.Count + LastRow - 1, JoinedRange.Columns.Count)).Value = JoinedRange.Value
 Set JoinedRange = Nothing
 End With
 End If
 End If
 FirstIteration = False
 PreviousValue = Cell.Value2
 Next
 'Clear the values on the sheet
 SourceSheet.Cells.ClearContents
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
 Debug.Print "Process took : " & Timer - MyTimer
 Exit Sub
ErrorHandler:
 'Restore state if there was an issue
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
End Sub