Avatar of Sam OZ
Sam OZ
Flag for Australia asked on

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

Avatar of undefined
Last Comment
Martin Liss

8/22/2022 - Mon
Norie

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

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

Log in or sign up to see answer
Become an EE member today7-DAY FREE TRIAL
Members can start a 7-Day Free trial then enjoy unlimited access to the platform
Sign up - Free for 7 days
or
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

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

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