Excel macro to split a sheet into multipe sheets

Looking for an excel macro ( or some similar thing) . I have a excel file with 100 k rows ( first row is header) . I want to create new sheets ( or new excel files) each not exceeding around 30 k automatically splitting the 100K rows . So there will be 4 sheets created

It desirable the header is copied to each of the sheets ( Not essential)

Note: It could be 90 K rows or it could be 120 k rows or 137234 rows . But splitting in 30 k is need not be kept as a variable

Microsoft ExcelMicrosoft Office

Last Comment

Martin Liss

8/22/2022 - Mon

Norie

12/14/2021

I'm sure there are better ways to do this these days, e.g. Power Query, but give this a try.

Option Explicit

Sub SplitSheet()
Dim wsSrc As Worksheet
Dim wsDst As Worksheet
Dim rngHdr As Range
Dim rngSrc As Range
Dim rngDst As Range
Dim NoRows As Long
Dim NoSheets As Long

    NoRows = 30000

    Set wsSrc = Sheets("Data")

    With wsSrc
        Set rngHdr = .Range("A1").CurrentRegion.Rows(1)
        Set rngSrc = .Range("A2").Resize(NoRows, rngHdr.Columns.Count)
    End With

    Do
        NoSheets = NoSheets + 1
        Set wsDst = Sheets.Add
        wsDst.Name = "Data" & NoSheets
        Set rngDst = wsDst.Range("A2")

        With wsDst
            rngHdr.Copy .Range("A1")
            rngSrc.Copy .Range("A2")
        End With
        Set rngSrc = rngSrc.Offset(NoRows)
    Loop Until rngSrc.Cells(1, 1) = ""

End Sub

Open in new window

Peter Chan

12/14/2021

Try in the similar way below:

Sub Produce_sheeets()
    Dim RID As Integer, Item0 As String
    RID = 2
    RID1 = 2
    RID2 = 1
    Count0 = 0
   
    Do While True
        Item0 = Trim(Worksheets("S0").Cells(RID, 5).Value)
        If Item0 = "" Then
            Count0 = Count0 + 1
        Else
            Count0 = 0
        End If
       
        If Count0 = 5 Then
            Exit Sub
        End If
       
        If Item0 <> "" Then
           If Count0 > 30000 Then
              Sheets.Add After:=Sheets("S0")
              'Append/copy cells's info to new sheet
              '..


        End If
       
        RID = RID + 1
    Loop
End Sub

Open in new window

ASKER CERTIFIED SOLUTION

Martin Liss

12/15/2021

Become an EE member today7-DAY FREE TRIAL

Members can start a 7-Day Free trial then enjoy unlimited access to the platform

Learn why we charge membership fees

We get it - no one likes a content blocker. Take one extra minute and find out why we block content.

Not exactly the question you had in mind?

Sign up for an EE membership and get your own personalized solution. With an EE membership, you can ask unlimited troubleshooting, research, or opinion questions.

ask a question

Robert Berke

12/16/2021

Give the points to the early responders. But this is probably the shortest code.

Dim i As Long, l As Long
With ActiveSheet.UsedRange
    l = (.Rows.Count + 4) / 4
    For i = 3 To 0 Step -1
        Sheets.Add
        .Cells.Offset(i * l).Resize(l, .Columns.Count).Copy
        ActiveSheet.Paste
    Next
End With
End Sub

Open in new window

Your help has saved me hundreds of hours of internet surfing.

fblack61

Martin Liss

1/8/2022

I’m glad I was able to help.

If you expand the “Full Biography" section of my profile you’ll find links to some articles I’ve written that may interest you.

Marty - Microsoft MVP 2009 to 2017
       Experts Exchange Most Valuable Expert (MVE) 2015, 2017
       Experts Exchange Distinguished Expert in Excel 2018
       Experts Exchange Top Expert Visual Basic Classic 2012 to 2020
       Experts Exchange Top Expert VBA 2018 to 2020