Question

我目前正在尝试通过excel中的列内的值将大型数据集（15列乘360,000+行）拆分为多个选项卡。我目前正在使用以下脚本，但宏似乎无法处理数据量（excel冻结）。我在缩短版本的数据上使用了脚本，它运行得很好。对这么大的数据集的任何建议都会很棒。

Sub SplitData()
Const NameCol = "O"
Const HeaderRow = 1
Const FirstRow = 2
Dim SrcSheet As Worksheet
Dim TrgSheet As Worksheet
Dim SrcRow As Long
Dim LastRow As Long
Dim TrgRow As Long
Dim Student As String
Application.ScreenUpdating = False
Set SrcSheet = ActiveSheet
LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
    Student = SrcSheet.Cells(SrcRow, NameCol).Value
    Set TrgSheet = Nothing
    On Error Resume Next
    Set TrgSheet = Worksheets(Student)
    On Error GoTo 0
    If TrgSheet Is Nothing Then
        Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        TrgSheet.Name = Student
        SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
    End If
    TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
    SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
Next SrcRow
Application.ScreenUpdating = True

End Sub

Answer 1

根据我的评论，如果您使用.RemoveDuplicates和.AutoFilter

，则可以加快整个代码的速度

逻辑：逻辑是将数据从Col 15（＆＃34; O＆＃34;）复制到新工作表。让我们说Col A.现在使用.RemoveDuplicates删除所有重复的值。现在，完成后，您将拥有工作表的唯一名称。只需检查这些工作表名称是否存在于循环中，如果他们不在 ONE GO 中创建所有工作表。

创建工作表后，只需使用Autofilter根据可从临时表中选取的工作表名称过滤掉数据。有了这个，你就不需要遍历每一行。您可以执行 MASS COPYING ，它比复制每一行更快：）

代码（未测试）

我很快写了这段代码，因此没有经过测试。如果您有任何错误，请告诉我。我已对代码进行了评论，因此您无法理解它。

Sub Sample()
    Dim ws As Worksheet, wsTemp As Worksheet
    Dim lRow As Long, colNo As Long, i As Long
    Dim NameCol As String, strCriteria As String
    Dim MyRange As Range

    NameCol = "O"

    '~~> Change this to the relevant sheet
    Set ws = ThisWorkbook.Sheets("Sheet1")

    '~~> Add Temp sheet
    ThisWorkbook.Sheets.Add
    Set wsTemp = ActiveSheet

    With ws
        lRow = .Cells(.Rows.Count, NameCol).End(xlUp).Row
        colNo = .Range(NameCol & 1).Column

        '~~> Copy the column to temp sheet
        .Columns(colNo).Copy wsTemp.Columns(1)

        Set MyRange = .Range("A1:O" & lRow)
    End With

    With wsTemp
        '~~> Remove duplicates
        .Columns(1).RemoveDuplicates Columns:=1, Header:=xlYes

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

        For i = 2 To lRow
            '~~> Check if the sheet exists
            If Not SheetExists(.Cells(i, 1).Value) Then
                '~~> Create New Sheet
                 ThisWorkbook.Sheets.Add.Name = (.Cells(i, 1).Value)
            End If
        Next i
    End With


    With ws
        '~~> Loop though the sheet names in the temp sheet
        For i = 2 To lRow
            strCriteria = wsTemp.Cells(i, 1)

            'Remove any filters
            .AutoFilterMode = False

            '~~> Filter range and do mass copying to relevant sheet
            With MyRange
                .AutoFilter Field:=15, Criteria1:=strCriteria

                .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
                ThisWorkbook.Sheets(strCriteria).Rows(1)
            End With

            'Remove any filters
            .AutoFilterMode = False
        Next i
    End With

    '~~> Delete Temp sheet
    Application.DisplayAlerts = False
    wsTemp.Delete
    Application.DisplayAlerts = False
End Sub

'~~> Function to check if the sheet exists
Function SheetExists(sName As String) As Boolean
    Dim sht As Worksheet

    On Error Resume Next
    Set sht = ThisWorkbook.Sheets(sName)
    On Error GoTo 0

    If Not sht Is Nothing Then SheetExists = True
End Function

Answer 2

对于未分类的记录集，这些事情可能需要很长时间。 Excel在排序记录上的工作速度要快得多，而且不仅可以一次复制比1条记录大得多的块。试试这个：

Sub SplitData()

Const NameCol = "O"
Const HeaderRow = 1
Const FirstRow = 2
Dim SrcSheet As Worksheet
Dim TrgSheet As Worksheet
Dim SrcRow As Long
Dim LastRow As Long
Dim TrgRow As Long
Dim Student As String

Application.ScreenUpdating = False
Set SrcSheet = ActiveSheet
LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row

'Sort first
Cells.Sort Key1:=Range(NameCol & "2"), Header:=xlYes

For SrcRow = FirstRow To LastRow

    'Get student name
    Student = SrcSheet.Cells(SrcRow, NameCol).Value

    'Gets first and last rows of that student's records
    startCopy = Columns(NameCol).Find(What:=Student, After:=Cells(1, NameCol), LookIn:=xlFormulas, LookAt:=xlWhole).Row
    endCopy = Columns(NameCol).Find(What:=Student, After:=Cells(LastRow + 1, NameCol), LookIn:=xlFormulas, LookAt:=xlWhole).Row

    'Create a sheet for that student, once only
    Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    TrgSheet.Name = Student

    'Copy the header data on that sheet
    SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)

    'Copy the student records over
    SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(2)

    'Move the "srcRow" cursor to the last record of the found student
    SrcRow = endCopy
Next SrcRow
Application.ScreenUpdating = True

End Sub

我还没有对它进行测试，但看起来效果会很好。

通过移动一小部分时间来节省大量资金，并消除了搜索学生表是否已创建的额外开销。

按列将大型数据集拆分为多个选项卡

2 个答案: