CODEWITHSUNDEEP
excelvba
Jonathan Morningstar
Jonathan Morningstar

Reputation: 431

Break up number of record in Excel

I have a spread sheet that on Sheet1 has 2 columns of data and over 39,000 rows. I want it to take 400 blocks of data and put them onto new sheets until it goes through the entire 39k. Any thoughts on how to do this?

Upvotes: 0

Views: 78

Answers (2)

chuff
chuff

Reputation: 5866

The code below should do the trick. It allows for the following:

  • Copying of header row(s), if any, on Sheet1, to the added worksheets

  • Change in the size of the data block by setting the variable blockSize

  • Consecutive ordering of the added sheets from Sheet 2 to Sheet "N"

  • Copying of the data to the new sheets in single blocks of 400 rows (i.e., not row-by-row)

Run time on a 42,000 row record set was about 10.5 seconds. Note that the procedure will throw an error if Sheet2, etc. already exist in the workbook.

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

Upvotes: 1

Daniel M&#246;ller
Daniel M&#246;ller

Reputation: 86600

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

Upvotes: 0

Related Questions