Create New Sheet from Unique Values in Column and Paste Entire Row - Large Data Set

Question

I am looking to take all unique values in Column D and, for each unique value, create a new sheet with that name and paste all rows with that value from Sheet1 into that new sheet. I have found a great solution to this problem that will work for small data sets but it will crash Excel with a larger number of rows (10000+). The answer was provided here by Luna Zhang: https://social.msdn.microsoft.com/Forums/office/en-US/ea461892-d5e0-4c5e-abca-6904d6a1f886/splitting-data-into-multiple-tabs-in-excel-2010

Sub CopyToTabs() 
    Dim ws As Worksheet
    Dim wsNEW As Worksheet
    Dim i As Integer
    Dim j As Integer

    Set ws = ActiveWorkbook.Worksheets("Sheet1")

    For i = 2 To ws.Range("A" & ws.Rows.Count).End(xlUp).Row
    CopyConditional ws, ws.Range("D" & i).Value
    Next i

End Sub

Sub CopyConditional(wsNODE As Worksheet, WhichName As String) '
    Const NameCol = "D" 'takes from column D
    Const FirstRow = 2 'starts at row 2

    Dim LastRow As Long
    Dim SrcRow As Long
    Dim TrgRow As Long
    Dim wsNEW As Worksheet

    On Error Resume Next
    Set wsNEW = Worksheets(WhichName) 'put this variable in the sheet with the same name as the variable
    If wsNEW Is Nothing Then 'if there isn't already a sheet with that unique variable name create one
        Set wsNEW = Worksheets.Add(After:=wsNODE) 'create new sheet after original worksheet
        wsNEW.Name = WhichName 'name of the unique variable in column D
    End If
    On Error GoTo 0

    wsNEW.Rows.Clear 'clear data in the newly created sheet
    wsNODE.Rows(1).Copy Destination:=wsNEW.Cells(1, 1) 'copy and paste the data from Sheet1 and
    'paste in sheet with the same name

    TrgRow = wsNEW.Cells(wsNEW.Rows.Count, NameCol).End(xlUp).Row + 1 'defines Target row to add to the
    'next empty row in the new sheet
    LastRow = wsNODE.Cells(wsNODE.Rows.Count, NameCol).End(xlUp).Row 'defines last row as the last row
    'on the NodeCal1 sheet

    For SrcRow = FirstRow To LastRow 'from row 2 to the last row in NodeCal1
        If wsNODE.Cells(SrcRow, NameCol) = WhichName Then 'if cell in column D = searching variable then
            wsNODE.Cells(SrcRow, 1).EntireRow.Copy Destination:=wsNEW.Cells(TrgRow, 1) 'copy
            TrgRow = TrgRow + 1 'paste in last empty row of the new sheet
        End If
    Next SrcRow

End Sub

Is there any way to reduce the time? I also tried a variant of the answer provided by Profex here: Efficient way to delete entire row if cell doesn't contain '@' and changed Sheet.Range(DeleteAddress).EntireRow.Delete to

Sheet.Range(CopyAddress).EntireRow.Copy

Worksheets.Add After:=Sheets(Sheets.Count) 
Range("A1").Select
ActiveSheet.Paste

But it returns error 1004.

I think using Autofilter to extract the relevant entries would be more efficient than looping through every row. You should be able to find examples online. — SJR, Jan 25 '19 at 16:10
Also, when working with large data set, I would recommend not to work with data on sheets. Import them into an array and then perform your tasks on that array before copying the required data back into your sheets. Although, in this instance, I would go with @SJR suggestion — Zac, Jan 25 '19 at 16:13
@SJR: true but with your approach, OP doesn't have to do much in the way of coding. They can just perform the filter in one statement and capture the results. Probably the case of priority over productivity :) — Zac, Jan 25 '19 at 16:23
Thanks but I'm not sure that would work. There are a lot of variable entities that can be present in column D so it would take a lot of time to filter each one and I have other calculations I need to make after the data is separated into different sheets. — Sarah, Jan 25 '19 at 16:28

score 1 · Accepted Answer · answered Jan 25 '19 at 17:19

Create a pivot table of your data!
Take the relevant column of your data as a row. (F1 in the example below)
Count the items for this row

Then display the details for each pivot element or call the Makro below to have the job done for you.

Sub CreatePivotTable()
    Sheets.Add
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "Sheet1!R3C1:R1048576C2", Version:=xlPivotTableVersion15).CreatePivotTable _
        TableDestination:=ActiveSheet.Range("A1"), TableName:="PivotTable1"
    With ActiveSheet.PivotTables("PivotTable1")
        .InGridDropZones = True
        .RowAxisLayout xlTabularRow
    End With

    With ActiveSheet.PivotTables("PivotTable1").PivotFields("F1")
        .Orientation = xlRowField
        .Position = 1
    End With

    ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _
        "PivotTable1").PivotFields("F1"), "Count of F1", xlCount

    With ActiveSheet.PivotTables("PivotTable1").PivotFields("F1")
        .Orientation = xlRowField
        .Position = 1
    End With
End Sub


Public Sub ShowAllPTDetail()
    Dim WB As Workbook
    Dim actWs As Worksheet
    Dim ptCounter As Long
    Dim pt As PivotTable
    Dim dataRange As Range
    Set WB = ThisWorkbook

    Sheets(1).Activate
    Set actWs = ActiveSheet

    With actWs
        If .PivotTables.Count > 0 Then
            For ptCounter = 1 To .PivotTables.Count
                Set pt = .PivotTables(ptCounter)
                Set dataRange = Range(pt.TableRange1.Address)
                For detailCt = 3 To dataRange.Rows.Count - 1
                    .Activate
                    dataRange(detailCt, dataRange.Columns.Count).Select
                    Selection.ShowDetail = True
                Next detailCt
            Next
        End If
    End With
End Sub

Create New Sheet from Unique Values in Column and Paste Entire Row - Large Data Set

1 Answers1