Create Sheets And Copy data To Each Sheet

[Dazzawm]

I have sheet 1 as laid out below I need a macro that will create sheets and name them the headings that is in row 1 starting in column C and copy their respective data. The amount of columns may vary on every file I use the code on.

Excel 2010

	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S
1	Part	Description	1	2	3	4	5	6	7	8	9	10	11	12	13	14	15	16	TOTAL
2	J4825024	Test 1	1	2	0	2	2	2	0	2	0	2	0	0	0	0	0	0	13
3	J4965013	Test 2	2	0	0	1	2	2	2	2	0	2	0	0	0	0	0	0	13
4	J4828004	Test 3	0	2	0	1	2	2	1	2	0	1	0	0	0	0	0	0	11

<tbody>
</tbody>

Sheet1​

This is how it would look with just a couple of the sheets as an example.

Excel 2010

	A	B	C
1	Part	Description
2	J4825024	Test 1	1
3	J4965013	Test 2	2
4	J4828004	Test 3	0

<tbody>
</tbody>

1​

Excel 2010

	A	B	C
1	Part	Description
2	J4825024	Test 1	2
3	J4965013	Test 2	0
4	J4828004	Test 3	2

<tbody>
</tbody>

2​

Thanks, any further clarification please let me know.

 

[Dazzawm]

The first sheet below is the raw data with a 'total' column in K and the code works perfect and splits it in to sheets named 1, 3, 4, 5, 6, 7, 8 & 10 just as I need it to.

Excel 2010
	A	B	C	D	E	F	G	H	I	J	K
1	Part	Description	1	3	4	5	6	7	8	10	Totals
2	N4892046	test1	1	0	1	2	2	0	1	2	9
3	J4962019	test2	0	1	0	2	0	1	0	0	4
4	J4962026	test3	0	0	1	2	-1	0	1	0	3
Sheet1

The sample below does not have a 'totals' column so when the code is run I only get sheets named 1, 3, 4, 5, 6, 7 & 8. No sheet 10

Excel 2010
	A	B	C	D	E	F	G	H	I	J
1	Part	Description	1	3	4	5	6	7	8	10
2	N4892046	test1	1	0	1	2	2	0	1	2
3	J4962019	test2	0	1	0	2	0	1	0	0
4	J4962026	test3	0	0	1	2	-1	0	1	0
Sheet1

I hope this is what you need as I don't know how to post a shot of the file after its been split into sheets. Thanks.

 

[hiker95]

Dazzawm,

You did not show what at least one of the resulting worksheets would look like. I hope that the following is correct.


Sample raw data in worksheet Sheet1:

Excel 2007
	A	B	C	D	E	F	G	H	I	J
1	Part	Description	1	3	4	5	6	7	8	10
2	N4892046	test1	1	0	1	2	2	0	1	2
3	J4962019	test2	0	1	0	2	0	1	0	0
4	J4962026	test3	0	0	1	2	-1	0	1	0
5
Sheet1

After the macro in just 3 of the 8 new worksheets (for brevity sake):

Excel 2007
	A	B	C
1	Part	Description	1
2	N4892046	test1	1
3	J4962019	test2	0
4	J4962026	test3	0
5
1

Excel 2007
	A	B	C
1	Part	Description	6
2	N4892046	test1	2
3	J4962019	test2	0
4	J4962026	test3	-1
5
6

Excel 2007
	A	B	C
1	Part	Description	10
2	N4892046	test1	2
3	J4962019	test2	0
4	J4962026	test3	0
5
10

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Sub CreateSheets_V3()
' hiker95, 08/20/2014, ME791312
Dim w1 As Worksheet
Dim lr As Long, lc As Long, c As Long, w As String
Application.ScreenUpdating = False
Set w1 = Sheets("Sheet1")
With w1
  lr = .Cells(.Rows.Count, 1).End(xlUp).Row
  lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
  For c = 3 To lc
    w = .Cells(1, c)
    If Not Evaluate("ISREF('" & w & "'!A1)") Then Worksheets.Add(After:=Sheets(Sheets.Count)).Name = w
    With Sheets(w)
      .UsedRange.Clear
      .Cells(1, 1).Resize(lr, 2).Value = w1.Range(w1.Cells(1, 1), w1.Cells(lr, 2)).Value
      .Range(.Cells(1, 3), .Cells(lr, 3)).Value = w1.Range(w1.Cells(1, c), w1.Cells(lr, c)).Value
      .Columns.AutoFit
    End With
  Next c
End With
w1.Activate
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the CreateSheets_V3 macro.

 

[Dazzawm]

Works perfect, it does add a totals sheet at the end but that's no problem I can just delete that. Thanks for your time.

 

[hiker95]

Dazzawm,

Thanks for the feedback.

You are very welcome. Glad I could help.

And, come back anytime.