Link to home
Start Free TrialLog in
Avatar of Sam OZ
Sam OZFlag 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 


Avatar of Norie
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

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
Avatar of Martin Liss
Martin Liss
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
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


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