Splitting data into seperate spreadsheets based on column values

[narendrabr]

Hi,
I have a data that has several columns. But I need to separate the spread sheet based on one particular column values.Please help.

Thanks,

[Olly]

Need a bit more detail than that.

Can you attach a workbook, and explain exactly what you are trying to achieve, based on which conditions?

[kalak]

here's one approach
the cl& = 2 near the top of the code says to use Column2 for your splitting
you can change this to any column you like.

Sub col_to_sheets()

Const cl& = 2
Dim a As Variant, x As Worksheet, sh As Worksheet
Dim rws&, cls&, p&, i&, rr&, b As Boolean
Application.ScreenUpdating = False
Sheets("sheet1").Activate
rws = Cells.Find("*", , , , xlByRows, xlPrevious).Row
cls = Cells.Find("*", , , , xlByColumns, xlPrevious).Column
Sheets.Add(After:=Sheets("Sheet1")).Name = Chr(30)
Set x = Sheets(Chr(30))
    Sheets("Sheet1").Cells(1).Resize(rws, cls).Copy x.Cells(1)
    Set a = x.Cells(1).Resize(rws, cls)
    a.Sort a(1, cl), 2, Header:=xlYes
    a = a.Resize(rws + 1)
    p = 2
    For i = p To rws + 1
        If a(i, cl) <> a(p, cl) Then
            b = False
            For Each sh In Worksheets
                If sh.Name = a(p, cl) Then b = True: Exit For
            Next
            If Not b Then Sheets.Add.Name = a(p, cl)
            With Sheets(a(p, cl))
                x.Cells(1).Resize(, cls).Copy .Cells(1)
                rr = .Cells.Find("*", , , , xlByRows, xlPrevious).Row + 1
                x.Cells(p, 1).Resize(i - p, cls).Cut .Cells(rr, 1)
            End With
            p = i
        End If
    Next i
Application.DisplayAlerts = False
    Sheets(Chr(30)).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

[narendrabr]

I have several columns in the spreadsheet and I need to split the spread sheet based on any clolumn values.It could be 1,2,...or n...
For Example
Clo1 col2 col3 col4
1 34 45 56
3 45 76 67
5 64 58 89

If I consider col2 values I need to pot each value for example 34,45,64 in different spread sheets.

Thanks

[kalak]

The above code creates sheets named "34", "45" and "58" if Col2 is used, and if sheets with those names don't exist already.

If that's not what you want, could you be more specific about just what it is that you do want?

[narendrabr]

Hi,

I need to separate the spread sheet based on any column values I select.
For example: If I select column say Country that contains values IND,USA,CHN,ESP. I want separate the main sheet into sub sheets based on these values.

Thanks

[kalak]

have your data on sheet1
select a cell in the column you want to operate with and run this macro

Sub sheets_from_colvalues()

Const sh1 As String = "Sheet1"
Dim a As Variant, x As Worksheet, sh As Worksheet
Dim rws&, cls&, p&, i&, rr&, b As Boolean
Dim cl&
cl = Selection.Column
Application.ScreenUpdating = False
Sheets(sh1).Activate
rws = Cells.Find("*", , , , xlByRows, xlPrevious).Row
cls = Cells.Find("*", , , , xlByColumns, xlPrevious).Column
Set x = Sheets.Add(After:=Sheets(sh1))
Sheets(sh1).Cells(1).Resize(rws, cls).Copy x.Cells(1)
Set a = x.Cells(1).Resize(rws, cls)
a.Sort a(1, cl), 2, Header:=xlYes
a = a.Resize(rws + 1)
    p = 2
    For i = p To rws + 1
        If a(i, cl) <> a(p, cl) Then
            b = False
            For Each sh In Worksheets
                If sh.Name = a(p, cl) Then b = True: Exit For
            Next
            If Not b Then
                With Sheets.Add
                    .Name = a(p, cl)
                    x.Cells(1).Resize(, cls).Copy .Cells(1)
                    rr = .Cells.Find("*", , , , xlByRows, xlPrevious).Row + 1
                    x.Cells(p, 1).Resize(i - p, cls).Cut .Cells(rr, 1)
                    .Columns.AutoFit
                End With
            End If
            p = i
        End If
    Next i
Application.DisplayAlerts = False
    x.Delete
Application.DisplayAlerts = True
Sheets(sh1).Activate
Application.ScreenUpdating = True
End Sub

[narendrabr]

Thanks but why it is not separating if the value is 0 in the column?

Thanks

[narendrabr]

Hi,

I this code not splitting data if the value is 0.

Thanks,
Narendra

[narendrabr]

Hi,

I need to create Ribbon Galleries for this code and need to name the main menu as 'validate values' and sub menu as 'split sheets'please help me on this.

Thanks,
Narendra

[kalak]

regarding posts #8 and #9, try

Sub col_to_sheetz()

Const cl& = 1
Dim lr&, lc&, s7, i&
Dim hdr, q As String, sh As Worksheet

Application.ScreenUpdating = False
lr = Cells.Find("*", , , , xlByRows, xlPrevious).Row
lc = Cells.Find("*", , , , xlByColumns, xlPrevious).Column
s = 2
Set ash = ActiveSheet

With Sheets.Add(after:=ash)
    ash.Cells(1).Resize(lr, lc).Copy .Cells(1)
    hdr = .Cells(1).Resize(, lc)
    .Cells(1).Resize(lr, lc).Sort .Cells(cl), Header:=xlYes
    a = .Cells(cl).Resize(lr + 1)
    For i = 2 To lr
        If a(i, 1) <> a(i + 1, 1) Then
            q = CStr(a(i, 1))
            On Error Resume Next
            Set sh = Sheets(q)
            On Error GoTo 0
            If sh Is Nothing Then
                Sheets.Add(after:=Sheets(Sheets.Count)).Name = q
                .Cells(s, 1).Resize(i - s + 1, lc).Copy Sheets(q).Cells(2, 1)
                s = i + 1
                Sheets(q).Cells(1).Resize(, lc) = hdr
             End If
        End If
    Next i
Application.DisplayAlerts = False
    .Delete
Application.DisplayAlerts = True
End With

ash.Activate
Application.ScreenUpdating = True
End Sub

[narendrabr]

Hi,

I need to create Ribbon Galleries for this code and need to name the main menu as 'validate values' and sub menu as 'split sheets' please help me on this.

Thanks,
Narendra

[narendrabr]

Hi,

I need to create Ribbon Galleries for this code and need to name the main menu as 'validate values' and sub menu as 'split sheets' please help me on this.
It should not come under add ins tab.
Thanks,
Narendra

[narendrabr]

Hi,

I am getting cannot rename a sheet with the same name if the values in the column are like A and a.It is taking uppercase and lower case case as different values.

Thanks!

[xlbiznes]

One more solution.

[xlbiznes]

Here you go, test this file and if you are satisfied save it as personal.xlsb file in

C:\Documents and Settings\Your Login Name\Application Data\Microsoft\Excel\XLSTART

[narendrabr]

Hi,,

Please provide steps to develop on my sheet.

Thanks!

[narendrabr]

Hi ,

I just opened your Updated Split Data Based On Key Column By Flabbiness.xlsm‎,it seems like the add-ins tab is attached to my local sheet as well.How to remove it?
Thanks

[narendrabr]

Hi,

Actually I need to create the tab in ribbon under that tab I need to create some sub tabs.

Please help.

[xlbiznes]

Check this code and change in places marked

Sub ADD_MENU()

Dim cbMainMenuBar As CommandBar
Dim cbcCutomMenu As CommandBarControl

'reset the commandbar
Application.CommandBars("Worksheet Menu Bar").Reset
On Error Resume Next


Application.CommandBars("Worksheet Menu Bar").Controls("&Split Data Based On Column Value").Delete

On Error GoTo 0

 Set cbMainMenuBar = _
     Application.CommandBars("Worksheet Menu Bar")
     
 Set cbcCutomMenu = cbMainMenuBar.Controls.Add(Type:=msoControlPopup)
 
     cbcCutomMenu.Caption = "Process" 
     cbcCutomMenu.OnAction = "unique_values_from_key_column" 'rename this to the macro that your are executing
End Sub

Call the add_menu code when your workbook is opened.

Private Sub Workbook_Open()
ADD_MENU
End Sub

[xlbiznes]

Reset the command bar.

'reset the commandbar
Application.CommandBars("Worksheet Menu Bar").Reset

[narendrabr]

Hi,

Actually I need to create the tab called data-validate on ribbon not inside add-ins and under that data-validate tab Need to create the tab called split-sheets.
For this code:
Sub col_to_sheetz()

Const cl& = 1
Dim lr&, lc&, s7, i&
Dim hdr, q As String, sh As Worksheet

Application.ScreenUpdating = False
lr = Cells.Find("*", , , , xlByRows, xlPrevious).Row
lc = Cells.Find("*", , , , xlByColumns, xlPrevious).Column
s = 2
Set ash = ActiveSheet

With Sheets.Add(after:=ash)
ash.Cells(1).Resize(lr, lc).Copy .Cells(1)
hdr = .Cells(1).Resize(, lc)
.Cells(1).Resize(lr, lc).Sort .Cells(cl), Header:=xlYes
a = .Cells(cl).Resize(lr + 1)
For i = 2 To lr
If a(i, 1) <> a(i + 1, 1) Then
q = CStr(a(i, 1))
On Error Resume Next
Set sh = Sheets(q)
On Error GoTo 0
If sh Is Nothing Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = q
.Cells(s, 1).Resize(i - s + 1, lc).Copy Sheets(q).Cells(2, 1)
s = i + 1
Sheets(q).Cells(1).Resize(, lc) = hdr
End If
End If
Next i
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With

ash.Activate
Application.ScreenUpdating = True
End Sub