Split data into different sheets

dxk7874
NewLounger
Posts: 1
Joined: 28 Feb 2017, 18:25

Split data into different sheets

Post by dxk7874 »

Good Morning,
How do I split a main data sheet into different sheets based on values in column A?

Thanks,
Dan
dkhemlall@gmail.com

User avatar
Rudi
gamma jay
Posts: 25336
Joined: 17 Mar 2010, 17:33
Location: Cape Town

Re: Split data into different sheets

Post by Rudi »

Welcome to Eileen's Lounge.

I have an "old" macro on hand that does the job. It is not the most optimal code, but it does the job.
Note that it refers to "Sheet1". You will need to change each reference to the sheet name in your workbook to make it work. (I said its not the most optimal!!! :smile: )

Code: Select all

Sub ExtractGroupsTSheet()
'Split Emails into individual sheets
Dim sh As Worksheet
Dim i As Integer
    Application.StatusBar = "Splitting data to individual sheets..."
    Application.ScreenUpdating = False
    With Sheets("Sheet1").Columns("A:A")
        .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        .Copy
    End With
    Sheets.Add(After:=ActiveSheet).Name = "FTemp"
    Columns("A:A").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Sheets("Sheet1").ShowAllData
    For i = 2 To Sheets("FTemp").Range("A" & Rows.Count).End(xlUp).Row
        Sheets("Sheet1").Range("A1").CurrentRegion.AutoFilter Field:=1, Criteria1:=Sheets("FTemp").Range("A" & i).Text
        On Error GoTo EH
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Sheets("FTemp").Range("A" & i).Value 'Split(Sheets("FTemp").Range("A" & i).Value, "@")(0)
        On Error GoTo 0
        With Sheets("Sheet1").AutoFilter.Range
            On Error Resume Next
            .Resize(.Rows.Count).SpecialCells(xlCellTypeVisible).EntireRow.Copy Destination:=ActiveSheet.Range("A1")
            ActiveSheet.Columns.AutoFit
            On Error GoTo 0
        End With
    Next i
    Sheets("Sheet1").AutoFilterMode = False
    Application.DisplayAlerts = False
    Sheets("FTemp").Delete
    Application.DisplayAlerts = True
    Sheets("Sheet1").Activate
    Application.StatusBar = False
    Application.ScreenUpdating = True
    Exit Sub
EH:
    Worksheets.Add After:=Worksheets(Worksheets.Count)
    ActiveSheet.Tab.Color = vbRed
    Resume Next
End Sub
Regards,
Rudi

If your absence does not affect them, your presence didn't matter.

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

Re: Split data into different sheets

Post by HansV »

Welcome to Eileen's Lounge from me too!

You'll need a VBA macro for this.

In the following, I'll assume that the first row contains column headers, and that you want to copy this row to each new sheet.

The macro should be run while the main data sheet is the active sheet.

Code: Select all

Sub SplitData()
    Dim s As Long
    Dim m As Long
    Dim t As Long
    Dim wshSource As Worksheet
    Dim wshTarget As Worksheet
    Dim strName As String
    Set wshSource = ActiveSheet
    Application.ScreenUpdating = False
    m = wshSource.Range("A" & wshSource.Rows.Count).End(xlUp).Row
    For s = 2 To m
        strName = wshSource.Range("A" & s).Value
        If strName <> "" Then
            Set wshTarget = Nothing
            On Error Resume Next
            Set wshTarget = Worksheets(strName)
            On Error GoTo 0
            If wshTarget Is Nothing Then
                Set wshTarget = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                wshTarget.Name = strName
                wshSource.Range("A1").EntireRow.Copy Destination:=wshTarget.Range("A1")
            End If
            t = wshTarget.Range("A" & wshTarget.Rows.Count).End(xlUp).Row + 1
            wshSource.Range("A" & s).EntireRow.Copy Destination:=wshTarget.Range("A" & t)
        End If
    Next s
    Application.ScreenUpdating = True
End Sub
Regards,
Hans