Splitting Macro

[Bobfred]

Hi I am looking for advice on how to create the following macro.

I have a spreadsheet of data that has columns A-Q.

The column headings are always the same name. I am wanting the Macro to split the data in column G and create new worksheets that displays that data. The number of Rows of data will always be different and is not a set amount

Column G usually has 4 different things in it. Red, Yellow, Blue, Black.

So after it is split I would want to see the following worksheets. Sheet1(Containg all data) Red(Contain all Red lines of data), Yellow(Contain all Yellow lines of data), Blue(Contain all Blue lines of data), Black(Contain all Red lines of data),

Ideally I would like to be able to split the data in other column headings. So whatever cell I select for example it will split it and create worksheets for those values. but if this is not possible then column G is fine but it would be good if I could do this on any column header and it would split by the different values in that column not including the header title

 

[kalak]

I kinda supposed you've be using an .xlsm file, but so long as you can get it to work OK ...

To use a splitting column based on cell selection (or first cell in any selected range) just change the red line in the above code to

cl = Selection.Cells(1).Column

 

[Bobfred]

Hi Kalak

That works great so thanks for that. I had added the code from a macro I recorded to the code you provided me with.

So I will start with 2 work sheets. One called All that contains the data and another called Best Colour Table.

I use your code to split the colour column in the All worksheet so I am left with worksheets All, Best Colour Table, Black, Blue, Yellow, Red.

What my recorded macro will then do is create a duplicate tab for each of the colours so you are left with All, Best Colour Table,Black, Black Unique, Blue, Blue Unique, Yellow, Yellow Unique, Red and Red Unique.

In the unique colour tabs it sorts them by a column in there. e.g quanity and then copy two columns from the unique colour worksheet and pastes it into a table in the worksheet Best Colour.

There will never be more than the 4 colours however sometimes there may only be Black and Blue once the data is split or Black, Blue and Red or anything other combination.

If this is the case then my macro wont work because it is relying that all 4 colour worksheets are present.

Is there a way that you can improve it to say if black is there then create unique otherwise move onto blue. If blue is not there move onto yellow, if yellow is not there move onto red. If red is not there then finish??




Sub splitz()


Dim cl As Long
Dim lr&, lc&, s&, i&
Dim hdr, q As String, d As Object, sh As Worksheet


cl = 7 'change this to whatever you like


Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
For Each sh In Worksheets
d(sh.Name) = 1
Next sh
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))
If Not d(q) = 1 Then
Sheets.Add(After:=Sheets(Sheets.Count)).Name = q
Else
Sheets(q).UsedRange.ClearContents
End If
.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
Next i
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
ash.Activate
Application.ScreenUpdating = True






Sheets("Black").Select
Sheets("Black").Copy Before:=Sheets("Blue")
Sheets("Black (2)").Select
Sheets("Black (2)").Name = "Black (Unique)"
Range("I1").Select
ActiveSheet.Range("$A$1:$Q$10000").RemoveDuplicates Columns:=9, Header:= _
xlYes
ActiveWorkbook.Worksheets("Black (Unique)").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Black (Unique)").Sort.SortFields.Add Key:=Range("I1") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Black (Unique)").Sort
.SetRange Range("A2:Q1000")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Sheets("Blue").Select
Sheets("Blue").Copy Before:=Sheets("Yellow")
Sheets("Blue (2)").Select
Sheets("Blue (2)").Name = "Blue (Unique)"
Range("I1").Select
ActiveSheet.Range("$A$1:$Q$10000").RemoveDuplicates Columns:=9, Header:=xlYes
ActiveWorkbook.Worksheets("Blue (Unique)").Sort.SortFields. _
Clear
ActiveWorkbook.Worksheets("Blue (Unique)").Sort.SortFields.Add _
Key:=Range("I1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets("Blue (Unique)").Sort
.SetRange Range("A2:Q1000")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Sheets("Yellow").Select
Sheets("Yellow").Copy Before:=Sheets("Red")
Sheets("Yellow (2)").Select
Sheets("Yellow (2)").Name = "Yellow (Unique)"
Range("I1").Select
ActiveSheet.Range("$A$1:$Q$10000").RemoveDuplicates Columns:=9, Header:=xlYes
ActiveWorkbook.Worksheets("Yellow (Unique)").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Yellow (Unique)").Sort.SortFields.Add Key:= _
Range("I1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Yellow (Unique)").Sort
.SetRange Range("A2:Q1000")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Sheets("Red").Select
Sheets("Red").Copy After:=Sheets("Red")
Sheets("Red (2)").Select
Sheets("Red (2)").Name = "Red (Unique)"
Range("I1").Select
ActiveSheet.Range("$A$1:$Q$10000").RemoveDuplicates Columns:=9, Header:= _
xlYes
ActiveWorkbook.Worksheets("Red (Unique)").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Red (Unique)").Sort.SortFields.Add Key:=Range("I1") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Red (Unique)").Sort
.SetRange Range("A2:Q1000")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("I2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ActiveWindow.ScrollWorkbookTabs Sheets:=1
Sheets("Best Colour Table").Select
Range("G3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Yellow (Unique)").Select
Range("I2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Best Colour Table").Select
Range("C3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Blue (Unique)").Select
Range("I2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Best Colour Table").Select
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWindow.ScrollWorkbookTabs Sheets:=-1
ActiveWindow.ScrollWorkbookTabs Sheets:=-1
ActiveWindow.ScrollWorkbookTabs Sheets:=-1
Sheets("Black (Unique)").Select
Range("I2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.ScrollWorkbookTabs Sheets:=1
ActiveWindow.ScrollWorkbookTabs Sheets:=1
ActiveWindow.ScrollWorkbookTabs Sheets:=1
Sheets("Best Colour Table").Select
Range("E3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A29").Select
End Sub