分解Excel中的记录数

Question

我有一个电子表格，在Sheet1上有2列数据和39000多行。我希望它取400个数据块，并将它们放在新的表上，直到它通过整个39k。有什么想法吗？

Answer 1

下面的代码应该可以完成任务。它允许以下内容：

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

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

• 从第2张到第张"N"添加的纸张的连续排序

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

创下42000个记录的运行时间约为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