Error 438"Object Doesn't Support This Property or Method"

Question

Related to Excel VBA - I have a large dataset and would like to split it by Ratings. For a small dataset the code works perfectly, but for a large dataset (11,000 rows & 20 columns), it loops and either get "Restart Excel program" or a 438 error. Need some help to optimize/correct the code. Using Excel 2013

I tried Cut/paste instead of copy/paste - it does not work

Private Sub SplitData_Click()
    a = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To a
        If Sheets("Sheet1").Cells(i, 2).Value = "AAA" Then
            Sheets("Sheet1").Rows(i).Cut
            Sheets("Sheet2").Activate
            b = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
            Sheets("Sheet2").Cells(b + 1, 1).Select
            ActiveSheet.Paste
        End If
        If Sheets("Sheet1").Cells(i, 2).Value = "BBB" Then
            Sheets("Sheet1").Rows(i).Cut
            Sheets("Sheet3").Activate
            c = Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Row
            Sheets("Sheet3").Cells(c + 1, 1).Select
            ActiveSheet.Paste
        End If
        If Sheets("Sheet1").Cells(i, 2).Value = "CCC" Then
            Sheets("Sheet1").Rows(i).Cut
            Sheets("Sheet4").Activate
            d = Sheets("Sheet4").Cells(Rows.Count, 1).End(xlUp).Row
            Sheets("Sheet4").Cells(d + 1, 1).Select
            ActiveSheet.Paste
        End If
        Sheets("Sheet1").Activate
    Next
    Application.CutCopyMode = False
End Sub

I want to split the large data set into different groups (Sheets) based on the value - AAA, BBB or CCC. I have 10 such value flags.

Answer 1

Here is an option without using copy/paste

Private Sub SplitData_Click()
    Dim a As Long
    Dim b As Long
    Dim c As Long
    Dim d As Long
    Dim i As Long

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet
    Dim ws4 As Worksheet

    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    Set ws3 = ThisWorkbook.Sheets("Sheet3")
    Set ws4 = ThisWorkbook.Sheets("Sheet4")

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    a = ws1.Cells(Rows.Count, 1).End(xlUp).Row

    For i = 2 To a

        If ws1.Cells(i, 2).Value = "AAA" Then
            b = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
            ws2.Rows(b).Value = ws1.Rows(i).Value

        End If
        If ws1.Cells(i, 2).Value = "BBB" Then
            c = Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Row + 1
            ws2.Rows(c).Value = ws1.Rows(i).Value
        End If
        If ws1.Cells(i, 2).Value = "CCC" Then
            d = Sheets("Sheet4").Cells(Rows.Count, 1).End(xlUp).Row + 1
            ws2.Rows(d).Value = ws1.Rows(i).Value
        End If

    Next i
    With Application
             .ScreenUpdating = True
             .Calculation = xlCalculationAutomatic
    End With
End Sub

Answer 2

Try this. This should be faster as this doesn't involve ANY looping.

Logic

1. Use Autofilter to Copy the rows across in one go
2. Clear rows after copying
3. Delete blank rows in one go using Autofilter

Code

Dim wsInput As Worksheet

Sub SplitData_Click()
    Dim wsOutputA As Worksheet
    Dim wsOutputB As Worksheet
    Dim wsOutputC As Worksheet

    Set wsInput = ThisWorkbook.Sheets("Sheet1")
    Set wsOutputA = ThisWorkbook.Sheets("Sheet2")
    Set wsOutputB = ThisWorkbook.Sheets("Sheet3")
    Set wsOutputC = ThisWorkbook.Sheets("Sheet4")

    Dim lrow As Long
    Dim rng As Range

    With wsInput
        .AutoFilterMode = False

        lrow = .Range("A" & .Rows.Count).End(xlUp).Row

        Set rng = .Range("A1:A" & lrow)

        '~~> Filter on AAA
        HandleIt "AAA", rng, wsOutputA

        '~~> Filter on BBB
        HandleIt "BBB", rng, wsOutputB

        '~~> Filter on CCC
        HandleIt "CCC", rng, wsOutputC

        '~~> Filter on blanks
        With rng
            .AutoFilter Field:=1, Criteria1:="="
            .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With

        .AutoFilterMode = False
    End With
End Sub

Private Sub HandleIt(AFCrit As String, r As Range, wks As Worksheet)
    Dim OutputRow As Long
    Dim filteredRange As Range

    With r
        .AutoFilter Field:=1, Criteria1:=AFCrit
        Set filteredRange = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
    End With

    If Not filteredRange Is Nothing Then
        With wks
            OutputRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
            filteredRange.Copy .Rows(OutputRow)
            filteredRange.ClearContents
        End With
    End If

    wsInput.ShowAllData
End Sub

In Action

Note: The above code took 4 seconds on 21k rows x 31 columns data

Answer 3

Another approach:

Private Sub SplitData_Click()

    Dim a As Long, i As Long, sht As Worksheet, sDest As String

    Set sht = Sheets("Sheet1")

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    a = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row

    For i = a To 2 Step -1 'work from bottom up
        sDest = ""
        'need to cut this row?
        Select Case sht.Cells(i, 2).Value
            Case "AAA": sDest = "Sheet2"
            Case "BBB": sDest = "Sheet3"
            Case "CCC": sDest = "Sheet4"
        End Select
        'cut row to relevant sheet
        If Len(sDest) > 0 Then
            sht.Rows(i).Cut Sheets(sDest).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        End If
    Next i

    Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic

End Sub

NOTE: locating the "cut to" cell using xlUp relies on every previous row in the destination sheet having a value in ColA - if any are empty then rows could get overwritten by the next pasted row.

Answer 4

Please see How to avoid using Select in Excel VBA.

Option Explicit

Private Sub SplitData_Click()
    Dim i As Long

    With Worksheets("Sheet1")
        For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
            Select Case .Cells(i, 2).Value
            Case "AAA"
                MoveToEndOf .Rows(i), Worksheets("Sheet2")
            Case "BBB"
                MoveToEndOf .Rows(i), Worksheets("Sheet3")
            Case "CCC"
                MoveToEndOf .Rows(i), Worksheets("Sheet4")
            End Select
        Next
    End With
End Sub

Private Sub MoveToEndOf(ByVal what As Range, ByVal where As Worksheet)
    what.Cut where.Cells(where.Rows.Count, 1).End(xlUp).Offset(1, 0)
End Sub