Создать новый лист из уникальных значений в столбце и вставить всю строку - большой набор данных

Question

Я собираюсь взять все уникальные значения в столбце D и для каждого уникального значения создать новый лист с этим именем и вставить все строки с этим значением из Sheet1 в этот новый лист.Я нашел отличное решение этой проблемы, которое будет работать для небольших наборов данных, но при этом произойдет сбой Excel с большим числом строк (более 10000).Ответ здесь дал Луна Чжан: 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

Есть ли способ сократить время?Я также попробовал вариант ответа, предоставленного Profex здесь: Эффективный способ удалить всю строку, если ячейка не содержит '@' и изменила Sheet.Range(DeleteAddress).EntireRow.Delete на

Sheet.Range(CopyAddress).EntireRow.Copy

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

Новозвращает ошибку 1004.

Answer 1

• Создайте сводную таблицу из ваших данных!
• Возьмите соответствующий столбец ваших данных в виде строки. (F1 в приведенном ниже примере)
• Считать элементы для этой строки

Затем отобразите детали для каждого элемента сводки или позвоните в макро ниже, чтобы выполнить работу за вас.

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