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

分解Excel中的记录数

2 个答案: