Keeping the formulas when you split a worksheet into multiple worksheets by change in row value

[sheetspread]

This is one of many similar macros that uses the advanced filter to give each category its own named tab:

 Option Explicit

Sub ParseItems()
'Author:    Jerry Beaucaire
'Date:      11/11/2009
'Summary:   Based on selected column, data is filtered to individual sheets
'           Creates sheets and sorts sheets alphabetically in workbook
'           6/10/2010 - added check to abort if only one value in vCol
'           7/22/2010 - added ability to parse numeric values consistently
'           11/16/2011 - changed way Unique values are collected, no Adv Filter

Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long, iCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, TitleRow As Long

Application.ScreenUpdating = False

'Column to evaluate from, column A = 1, B = 2, etc.
   vCol = 1
 
'Sheet with data in it
   Set ws = Sheets("Data")

'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
    vTitles = "A1:Z1"
    TitleRow = Range(vTitles).Cells(1).Row

'Spot bottom row of data
   LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

'Get a temporary list of unique values from vCol
    iCol = ws.Columns.Count
    ws.Cells(1, iCol) = "key"
   
    For Itm = 2 To LR
        On Error Resume Next
        If ws.Cells(Itm, vCol) <> "" And Application.WorksheetFunction _
            .Match(ws.Cells(Itm, vCol), ws.Columns(iCol), 0) = 0 Then
               ws.Cells(ws.Rows.Count, iCol).End(xlUp).Offset(1) = ws.Cells(Itm, vCol)
        End If
    Next Itm
'Sort the temporary list
    ws.Columns(iCol).Sort Key1:=ws.Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

'Put list into an array for looping
    MyArr = Application.WorksheetFunction.Transpose _
        (ws.Columns(iCol).SpecialCells(xlCellTypeConstants))

'clear temporary list
    ws.Columns(iCol).Clear

'Turn on the autofilter
    ws.Range(vTitles).AutoFilter

'Loop through list one value at a time
'The array includes the title cell, so we start at the second value in the array
'In case values are numerical, we convert them to text with ""
    For Itm = 2 To UBound(MyArr)
        ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm) & ""
   
        If Not Evaluate("=ISREF('" & MyArr(Itm) & "'!A1)") Then    'create sheet if needed
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = MyArr(Itm) & ""
        Else                                                      'clear sheet if it exists
            Sheets(MyArr(Itm) & "").Move After:=Sheets(Sheets.Count)
            Sheets(MyArr(Itm) & "").Cells.Clear
        End If
   
        ws.Range("A" & TitleRow & ":A" & LR).EntireRow.Copy _
            Sheets(MyArr(Itm) & "").Range("A1")
       
        ws.Range(vTitles).AutoFilter Field:=vCol
        MyCount = MyCount + Sheets(MyArr(Itm) & "").Range("A" & Rows.Count) _
                             .End(xlUp).Row - Range(vTitles).Rows.Count
        Sheets(MyArr(Itm) & "").Columns.AutoFit
    Next Itm
   
'Cleanup
    ws.AutoFilterMode = False
        ws.Activate
    MsgBox "Rows with data: " & (LR - TitleRow) & vbLf & "Rows copied to other sheets: " _
                & MyCount & vbLf & "Hope they match!!"

Application.ScreenUpdating = True
End Sub

Converting something like:

Excel Workbook
	A	B	C	D	E
1	Group	Name	Number	NextNumber	Formula
2	Alpha	Monday	2	1	4
3	Alpha	Tuesday	5	1	10
4	Alpha	Wednesday	6	4	30
5	Alpha	Thursday	5	8	45
6	Alpha	Friday	1	8	9
7	Alpha	Saturday	3	0	3
8	Alpha	Sunday	4	9	40
9	Alpha	Monday	1	7	8
10	Alpha	Tuesday	1	2	3
11	Alpha	Wednesday	3	9	30
12	Beta	Thursday	4	9	40
13	Beta	Friday	6	9	60
14	Beta	Saturday	6	8	54
15	Beta	Sunday	9	0	9
16	Beta	Monday	8	7	64
17	Beta	Tuesday	2	5	12
18	Gamma	Wednesday	5	8	45
19	Gamma	Thursday	3	1	6
20	Gamma	Friday	2	4	10
21	Gamma	Saturday	3	3	12
22	Gamma	Sunday	3	6	21
23	Gamma	Monday	7	4	35
24	Gamma	Tuesday	9	2	27
25	Gamma	Wednesday	8	0	8
26	Gamma	Thursday	7	2	21
27	Gamma	Friday	4	5	24
28	Gamma	Saturday	7	5	42
Data

to:

Excel Workbook
	A	B	C	D	E
1	Group	Name	Number	NextNumber	Formula
2	Alpha	Monday	2	1	4
3	Alpha	Tuesday	5	1	10
4	Alpha	Wednesday	6	4	30
5	Alpha	Thursday	5	8	45
6	Alpha	Friday	1	8	9
7	Alpha	Saturday	3	0	3
8	Alpha	Sunday	4	9	40
9	Alpha	Monday	1	7	8
10	Alpha	Tuesday	1	2	3
11	Alpha	Wednesday	3	9	30
Alpha

and

Excel Workbook
	A	B	C	D	E
1	Group	Name	Number	NextNumber	Formula
2	Beta	Thursday	4	9	40
3	Beta	Friday	6	9	60
4	Beta	Saturday	6	8	54
5	Beta	Sunday	9	0	9
6	Beta	Monday	8	7	64
7	Beta	Tuesday	2	5	12
Beta

for as many different groups as listed......

The column E formulas can only be seen in the alpha tab, because the references are identical to those in the original data sheet. Beta, gamma, etc only show values. Can this be fixed so all the formulas appear as such? Or is it a limit of using the filter instead of writing the code to copy, paste, and create each worksheet?

 

[sheetspread]

This does it:

Sub addonesheetforeachgroupofrows()

    Dim rLNColumn As Range
    Dim rCell As Range
    Dim sh As Worksheet
    Dim shDest As Worksheet
    Dim rNext As Range

    Const sLNHEADER As String = "Group"

    Set sh = ThisWorkbook.Sheets("Data")
    Set rLNColumn = sh.UsedRange.Find(sLNHEADER, , xlValues, xlWhole)

    'Make sure you found something
    If Not rLNColumn Is Nothing Then
        'Go through each cell in the column
        For Each rCell In Intersect(rLNColumn.EntireColumn, sh.UsedRange).Cells
            'skip the header and empty cells
            
            If Not IsEmpty(rCell.Value) And rCell.Address <> rLNColumn.Address Then
                'see if a sheet already exists
                On Error Resume Next
                    Set shDest = sh.Parent.Sheets(rCell.Value)
                On Error GoTo 0

                'if it doesn't exist, make it
                If shDest Is Nothing Then
                    Set shDest = sh.Parent.Worksheets.Add
                    shDest.Name = rCell.Value
                End If

                'Find the next available row
                Set rNext = shDest.Cells(shDest.Rows.Count, 1).End(xlUp).Offset(1, 0)

                'Copy and paste
                Intersect(rCell.EntireRow, sh.UsedRange).Copy rNext

                'reset the destination sheet
                Set shDest = Nothing
            End If
            
        Next rCell
    End If
    
    'add headers to sheets
    
    Counter = Sheets.Count
    For i = 1 To Counter
        Sheets("Data").Cells(1, 1).EntireRow.Copy
        Sheets(i).Cells(1, 1).PasteSpecial
         
    Next i
     
    Application.CutCopyMode = False

End Sub

 

[DarlaLu]

This worked great except it didn't create a worksheet for one dept. It created a separate worksheet for all the other dept just kept leaving off 1....always the same one...

 

[sheetspread]

Was it the first or last? In which cell does your table begin? And which code did you run?

 

[DarlaLu]

Was it the first or last? In which cell does your table begin? And which code did you run?

I used the first code.
It wasn't the first or the last row....mixed in. My table begins in A1 and goes to V96753. Column R is where my different department names are.

 

[sheetspread]

vcol should be 18 if it's R

 

[DarlaLu]

vcol should be 18 if it's R

I have it set to 18.

 

[sheetspread]

It was fine in my test. I named a sheet Data (otherwise change line 21 in the code) and set vcol to 18. Here's the sample before:

Excel 2010
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V
1	Name1	Series1	Name3	Name4	Name5	Series2	Series3	Series8	Series9	Name10	Name11	Name12	Name13	Series14	Series15	Series16	Series17	Name18	Name19	Name20	Name21	Name22
2	TAO	AYO	GEX	ELY	RHQ	NAP	85	59	66	99	49	78	79	55	64	20	23	BLL	GBU	FRQ	BPX	CQA
3	OOR	EWD	BRD	UMP	DSN	AGG	46	94	100	62	57	49	71	14	14	51	98	BLL	UOM	LIV	HAZ	BXX
4	ROY	BRM	VEJ	ARD	DDN	TNS	5	38	52	8	28	30	72	78	55	84	9	BLL	NNJ	LJX	GSM	SOX
5	MQR	VWN	FYG	LPJ	FXB	AZW	6	15	29	72	19	66	45	21	31	83	66	BLL	ONE	VBJ	FBX	ABK
6	KUT	OYE	PKC	YU	ZR	UHD	24	26	57	73	77	90	29	44	98	92	70	BLL	TWN	KBF	QHV	GQJ
7	QYJ	GOV	EJG	LOT	NBJ	TBX	77	83	60	35	22	83	40	92	73	59	42	BLL	BVX	RTV	BOD	GLU
8	ABG	BBI	FPT	VXZ	STF	RUI	82	66	82	75	100	4	68	57	18	22	98	BLL	CRI	WJX	NEU	IGT
9	PRG	CDA	TXX	VLY	QUJ	QGZ	42	85	10	45	45	69	20	33	79	8	66	BLL	HJR	TOQ	WBJ	BFG
10	VLT	EOJ	OCQ	WBN	FYB	NEP	27	84	35	8	1	68	9	61	46	82	92	LQD	NFR	MQZ	DUY	RZ
11	SNH	GLC	FVU	HMM	JBK	MHL	6	15	54	75	31	43	100	18	50	43	28	QLU	DLI	MGH	BRV	KJX
12	LIM	EKX	RIN	KAK	DIH	UKR	85	79	51	91	56	17	61	52	56	92	57	IVO	KB	HRG	OGL	JCT
13	BKQ	IQA	GGZ	FVE	MBP	NLC	70	72	66	72	17	1	71	67	38	74	84	IVO	DTC	HUM	CTD	JRY
14	JKQ	RTO	HWS	MBD	DYO	VFZ	37	95	46	42	33	94	75	50	83	20	40	IVO	VKS	TRM	CGB	PYE
15	MJA	DJP	LRX	CU	MJL	CDJ	94	61	85	85	99	8	11	91	4	3	69	PBM	MKH	JRR	LXQ	WFT
16	CGB	TIE	VKL	BBH	BXJ	RKZ	16	62	29	32	59	64	66	85	63	65	1	OUH	QYP	MZQ	WW	UGT
17	FJF	VCI	AYU	QBX	GXN	OVG	18	52	43	6	12	73	16	10	64	99	34	BDM	NPS	BGP	AKM	OBS
18	UWQ	RLW	GZG	LRE	MPL	IXV	58	45	68	86	21	80	9	34	58	9	98	BDM	IEW	MHJ	MOH	OKO
19	CPX	GTX	WBM	DNT	QIZ	JCE	18	97	67	8	7	73	2	61	39	38	77	BDM	IAE	RHA	UCI	QBC
20	HVR	EQO	MHH	QTM	OBB	LMW	41	2	63	70	59	15	23	58	91	90	65	PMM	NCD	NGP	QHH	HSM
21	PMB	HYM	URJ	VIG	VVQ	COT	89	60	36	45	93	96	22	42	64	71	69	PMM	TPG	VUG	UQB	TRE
Data

It split the sheet by the 8 names alphabetically. I can test another sample if you want.