excel - Excelでレコード数を分割する

Question

Sheet1 に 2 列のデータと 39,000 行を超えるスプレッド シートがあります。400 ブロックのデータを取り、39k 全体を通過するまで新しいシートに配置したいと考えています。これを行う方法について何か考えはありますか？

Answer 1

以下のコードでうまくいくはずです。これにより、次のことが可能になります。

• 追加されたワークシートへのシート 1 のヘッダー行のコピー (存在する場合)

• 変数 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