excel - 在Excel中分解记录数

Question

我有一个电子表格，在 Sheet1 上有 2 列数据和超过 39,000 行。我希望它获取 400 个数据块并将它们放在新的工作表上，直到它通过整个 39k。关于如何做到这一点的任何想法？

Answer 1

下面的代码应该可以解决问题。它允许执行以下操作：

• 将 Sheet1 上的标题行（如果有）复制到添加的工作表

• 通过设置变量blockSize改变数据块的大小

• 将添加的工作表从工作表 2 连续排序到工作表“N”

• 将数据以 400 行的单个块复制到新工作表（即，不是逐行）

42,000 行记录集的运行时间约为 10.5 秒。请注意，如果工作簿中已存在 Sheet2 等，则该过程将引发错误。

Option Explicit

Sub MoveDataToNewSheets()

    Dim ws1 As Worksheet
    Dim lastSel As Range
    Dim header As Range, lastCell As Range
    Dim numHeaderRows As Long, lastRow As Long, lastCol As Long
    Dim blockSize As Long, numBlocks As Long
    Dim i As Long

    numHeaderRows = 1  '<=== adjust for header rows (if none in Sheet1, set to zero)
    blockSize = 400    '<=== adjust if data blocks of a different size is desired

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

    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set lastSel = Selection

    With ws1
'       lastCell is bottom right corner of data in Sheet1
        Set lastCell = .Cells(.Cells.Find(What:="*", SearchOrder:=xlRows, _
            SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row, _
            .Cells.Find(What:="*", SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious, LookIn:=xlFormulas).Column)
    End With
    lastRow = lastCell.Row
    lastCol = lastCell.Column

    If numHeaderRows > 0 Then
        Set header = ws1.Range(ws1.Cells(1, 1), ws1.Cells(numHeaderRows, _
            lastCol))
    End If
    numBlocks = Application.WorksheetFunction.RoundUp((lastRow - _
        numHeaderRows) / blockSize, 0)

    For i = 1 To numBlocks
        DoEvents
        With ThisWorkbook
            Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = _
                ("Sheet" & (i + 1))
        End With
        If numHeaderRows > 0 Then
            header.Copy Destination:=Range("A1")
        End If
'       ' copy data block to newly inserted worksheets
        ws1.Range(ws1.Cells(numHeaderRows + 1 + ((i - 1) * blockSize), _
            1), ws1.Cells(numHeaderRows + i * blockSize, lastCol)).Copy _
            Destination:=Range("A" & (numHeaderRows + 1))
    Next

    ws1.Select
    lastSel.Select

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

Answer 2

Dim MainSheet As Worksheet
Set MainSheet = ThisWorkbook.Worksheets("NameOfMainSheet")

Dim WS as Worksheet
for i = 0 to 40000 step 400
    set WS = ThisWorkbook.Worksheets.Add()

    for j = 1 to 400
       WS.Cells(j,1).Value = MainSheet.Cells(i + j, 1)
       WS.Cells(j,2).Value = MainSheet.Cells(i + j, 2)
    next
next