Good Morning,
How do I split a main data sheet into different sheets based on values in column A?
Thanks,
Dan
dkhemlall@gmail.com
Split data into different sheets
-
- gamma jay
- Posts: 25455
- Joined: 17 Mar 2010, 17:33
- Location: Cape Town
Re: Split data into different sheets
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!!! )
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
Regards,
Rudi
If your absence does not affect them, your presence didn't matter.
Rudi
If your absence does not affect them, your presence didn't matter.
-
- Administrator
- Posts: 78475
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: Split data into different sheets
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.
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
Best wishes,
Hans
Hans