Split data into different sheets

[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

[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!!! )

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

[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