Question

我希望在D列中获取所有唯一值，并为每个唯一值创建一个具有该名称的新工作表，并将Sheet1中具有该值的所有行粘贴到该新工作表中。我已经找到了解决此问题的好方法，该方法适用于小型数据集，但它将使具有较大行数（10000+）的Excel崩溃。答案由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

有什么办法可以减少时间？我还尝试了Profex在此处提供的答案的一种变体：Efficient way to delete entire row if cell doesn't contain '@'，并进行了更改 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）
计算这一行的项目

然后显示每个枢轴元素的详细信息，或致电下面的Makro为您完成工作。

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

从列和粘贴整个行中的唯一值创建新图纸-大数据集

1 个答案: