Split worksheet into multiple

shreeram.maroo
2StarLounger
Posts: 181
Joined: 19 Feb 2016, 16:54
Location: Veraval, India

Split worksheet into multiple

Post by shreeram.maroo »

Hi
I am working on a worksheet with 9 lakh line items. I need to split this into multiple worksheets, based on values of 'ID' column. Can you suggest me a way for this. I tried certain vba codes available online, but those are not working for 9 lakh items.

Below is one of the code:

Code: Select all

Sub Splitdatabycol()
'updateby Extendoffice
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim xTRg As Range
Dim xVRg As Range
Dim xWSTRg As Worksheet
On Error Resume Next
Set xTRg = Application.InputBox("Please select the header rows:", "Kutools for Excel", "", Type:=8)
If TypeName(xTRg) = "Nothing" Then Exit Sub
Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "Kutools for Excel", "", Type:=8)
If TypeName(xVRg) = "Nothing" Then Exit Sub
vcol = xVRg.Column
Set ws = xTRg.Worksheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = xTRg.AddressLocal
titlerow = xTRg.Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
Application.DisplayAlerts = False
If Not Evaluate("=ISREF('xTRgWs_Sheet!A1')") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
Else
Sheets("xTRgWs_Sheet").Delete
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
End If
Set xWSTRg = Sheets("xTRgWs_Sheet")
xTRg.Copy
xWSTRg.Paste Destination:=xWSTRg.Range("A1")
ws.Activate
For i = (titlerow + xTRg.Rows.Count) To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
xWSTRg.Range(title).Copy
Sheets(myarr(i) & "").Paste Destination:=Sheets(myarr(i) & "").Range("A1")
ws.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A" & (titlerow + xTRg.Rows.Count))
Sheets(myarr(i) & "").Columns.AutoFit
Next
xWSTRg.Delete
ws.AutoFilterMode = False
ws.Activate
Application.DisplayAlerts = True
End Sub

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Split worksheet into multiple

Post by HansV »

Is the ID column a fixed column? If so, which column?
Best wishes,
Hans

shreeram.maroo
2StarLounger
Posts: 181
Joined: 19 Feb 2016, 16:54
Location: Veraval, India

Re: Split worksheet into multiple

Post by shreeram.maroo »

So column A is the id column and has unique ID numbers . There could be around 100-200 records against one id. I need to split the sheets based on ID column.

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Split worksheet into multiple

Post by HansV »

Thanks!

Are the data sorted by ID? If not, would it be OK to sort them by ID?
Best wishes,
Hans

shreeram.maroo
2StarLounger
Posts: 181
Joined: 19 Feb 2016, 16:54
Location: Veraval, India

Re: Split worksheet into multiple

Post by shreeram.maroo »

Yes, those could be sorted by ID. However I was looking for a way if these could be split into multiple sheets so that one sheet has records of only one ID.

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Split worksheet into multiple

Post by HansV »

Try this macro:

Code: Select all

Sub SplitData()
    Dim wshS As Worksheet
    Dim wshT As Worksheet
    Dim r As Long
    Dim r0 As Long
    Dim m As Long
    Dim ID
    Application.ScreenUpdating = False
    Set wshS = ActiveSheet
    m = wshS.Range("A" & Rows.Count).End(xlUp).Row
    wshS.Range("1:" & m).Sort Key1:=wshS.Range("A1"), Header:=xlYes
    r = 2
    Do
        If wshS.Range("A" & r).Value <> wshS.Range("A" & r - 1).Value Then
            Set wshT = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            wshT.Name = wshS.Range("A" & r).Value
            wshT.Range("1:1").Value = wshS.Range("1:1").Value
            ID = wshS.Range("A" & r).Value
            r0 = r
            Do While wshS.Range("A" & r + 1).Value = ID
                r = r + 1
            Loop
            wshT.Range("2:" & r - r0 + 2).Value = wshS.Range(r0 & ":" & r).Value
        End If
        r = r + 1
    Loop Until r > m
    Application.ScreenUpdating = True
End Sub
Best wishes,
Hans

shreeram.maroo
2StarLounger
Posts: 181
Joined: 19 Feb 2016, 16:54
Location: Veraval, India

Re: Split worksheet into multiple

Post by shreeram.maroo »

Thanks Hans. Apparently it is working. But since the data is bulky, it is taking much time, hence I stopped in between. Will try is thoroughly once I am at peace :)

Regards
Shreeram

shreeram.maroo
2StarLounger
Posts: 181
Joined: 19 Feb 2016, 16:54
Location: Veraval, India

Re: Split worksheet into multiple

Post by shreeram.maroo »

Hi,

Is there any way, we can keep repeat the first 4 or 5 rows in all the sheets ?

Regards
Shreeram

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Split worksheet into multiple

Post by HansV »

Like this:

Code: Select all

Sub SplitData()
    Const HeaderRows = 4
    Dim wshS As Worksheet
    Dim wshT As Worksheet
    Dim r As Long
    Dim r0 As Long
    Dim LastRow As Long
    Dim ID
    Application.ScreenUpdating = False
    Set wshS = ActiveSheet
    LastRow = wshS.Range("A" & Rows.Count).End(xlUp).Row
    wshS.Range(HeaderRows & ":" & LastRow).Sort Key1:=wshS.Range("A" & HeaderRows), Header:=xlYes
    r = HeaderRows + 1
    Do
        If wshS.Range("A" & r).Value <> wshS.Range("A" & r - 1).Value Then
            Set wshT = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            wshT.Name = wshS.Range("A" & r).Value
            wshT.Range("1:" & HeaderRows).Value = wshS.Range("1:" & HeaderRows).Value
            ID = wshS.Range("A" & r).Value
            r0 = r
            Do While wshS.Range("A" & r + 1).Value = ID
                r = r + 1
            Loop
            wshT.Range(HeaderRows + 1 & ":" & r - r0 + 2).Value = wshS.Range(r0 & ":" & r).Value
        End If
        r = r + 1
    Loop Until r > LastRow
    Application.ScreenUpdating = True
End Sub
Change the constant HeaderRows as needed.
Best wishes,
Hans

shreeram.maroo
2StarLounger
Posts: 181
Joined: 19 Feb 2016, 16:54
Location: Veraval, India

Re: Split worksheet into multiple

Post by shreeram.maroo »

Thanks Hans.