Make new sheets based on cells of master list

[wmtsub]

I am trying to take all the rows from the man page that cell row "E" has the same data and create a new tab named on that data and move them there.
Also the same with all other entries in row e. So at the end the first sheet "DATA" will be empty and deleted and I will have 6,8,10,20 new sheets each with only the pertinent data for that sheet. so if it was a list of colors - red - blue- green-yellow I would have four new sheets labeled one for each color and all the rows that have that color in that cell were moved to that new sheet.

Also the first row is a header row and needs to be on all the sheets.

But I can seem to get any closer....
Can anyone help?


'Add tabs
Set mysh = ActiveWorkbook.Sheets("Data")
lr = Range("A1").End(xlDown).row
For L = lr To 1 Step -1
For x = 1 To lr
If mysh.Cells(x, 7).Value = "" Then
GoTo row
End If
If mysh.Cells(x, 7).Value <> "" And counter = 0 Then
mystr = mysh.Cells(x, 7).Value
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = mystr
mysh.Rows(1).Copy ws.Rows(1)
counter = 1
End If
If mysh.Cells(x, 7).Value = mystr Then
mysh.Rows(x).Copy ws.Rows(rownum2)
mysh.Rows(x).ClearContents
rownum2 = rownum2 + 1
End If
row:
rownum = rownum + 1
rownum2 = 2
Next x
counter = 0
Next L

 

[KolGuyXcel]

Check if this is what you are looking for!

Sub sh_fltr()
Dim ws As Worksheet, snms As Scripting.Dictionary
Dim l_row As Long, i As Long
Dim ky As Variant, bool_k As Boolean
bool_k = False
Set snms = New Scripting.Dictionary
l_row = Sheets("DATA").Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To l_row
If Not snms.exists(Sheets("DATA").Cells(i, 5).Value2) Then
snms.Add Sheets("DATA").Cells(i, 5).Value2, Nothing
End If
Next
For Each ky In snms.Keys
For Each ws In ThisWorkbook.Worksheets
If ky = ws.Name Then
Sheets("DATA").Range(Cells(1, 1), (Cells(1, Cells(1, Columns.Count).End(xlToLeft).Column))).Copy
Sheets(ws.Name).Range("A1").PasteSpecial
bool_k = True
Exit For
End If
Next
If bool_k = False Then
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = ky
Sheets("DATA").Range(Cells(1, 1), (Cells(1, Cells(1, Columns.Count).End(xlToLeft).Column))).Copy
Range("A1").PasteSpecial
End If
Next
For i = 2 To l_row
Sheets("DATA").Range(Cells(i, 1), (Cells(i, Cells(1, Columns.Count).End(xlToLeft).Column))).Copy
Sheets(Sheets("DATA").Cells(i, 5).Value2).Cells(Sheets(Sheets("DATA").Cells(i, 5).Value2).Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial
Next
End Sub

 

[wmtsub]

thank you