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


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


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

2 Answers 2


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

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.

  • \$\begingroup\$ While...Wend should be Do While...Loop, and not involving the clipboard (assuming only the values are needed) would be even faster. \$\endgroup\$ Commented Jan 10, 2019 at 20:56
  • \$\begingroup\$ thanks for the syntax fix. I have no idea how to fix that clipboard issue, though.... \$\endgroup\$
    – Vogel612
    Commented Jan 10, 2019 at 21:00
  • \$\begingroup\$ 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 \$\endgroup\$
    – Pettsy100
    Commented Jan 11, 2019 at 7:19
  • 1
    \$\begingroup\$ I don't think this code shifts cells up after cutting. So the first iteration would work, but then it will always be blank. \$\endgroup\$ Commented Jan 11, 2019 at 12:51
  • \$\begingroup\$ @RyanWildry I think I fixed that now :) \$\endgroup\$
    – Vogel612
    Commented Jan 11, 2019 at 13:28

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
                    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

    'Clear the values on the sheet

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Debug.Print "Process took : " & Timer - MyTimer
    Exit Sub

    'Restore state if there was an issue
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.