Make new sheets based on cells of master list

wmtsub

Active Member
Joined
Jun 20, 2018
Messages
322
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
 

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).

KolGuyXcel

Board Regular
Joined
Jun 29, 2018
Messages
131
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
 

Forum statistics

Threads
1,148,108
Messages
5,744,878
Members
423,908
Latest member
Getfour

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top