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

sheetspread

Well-known Member
Joined
Sep 19, 2005
Messages
5,161
This is one of many similar macros that uses the advanced filter to give each category its own named tab:

Code:
 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
ABCDE
1GroupNameNumberNextNumberFormula
2AlphaMonday214
3AlphaTuesday5110
4AlphaWednesday6430
5AlphaThursday5845
6AlphaFriday189
7AlphaSaturday303
8AlphaSunday4940
9AlphaMonday178
10AlphaTuesday123
11AlphaWednesday3930
12BetaThursday4940
13BetaFriday6960
14BetaSaturday6854
15BetaSunday909
16BetaMonday8764
17BetaTuesday2512
18GammaWednesday5845
19GammaThursday316
20GammaFriday2410
21GammaSaturday3312
22GammaSunday3621
23GammaMonday7435
24GammaTuesday9227
25GammaWednesday808
26GammaThursday7221
27GammaFriday4524
28GammaSaturday7542
Data


to:

Excel Workbook
ABCDE
1GroupNameNumberNextNumberFormula
2AlphaMonday214
3AlphaTuesday5110
4AlphaWednesday6430
5AlphaThursday5845
6AlphaFriday189
7AlphaSaturday303
8AlphaSunday4940
9AlphaMonday178
10AlphaTuesday123
11AlphaWednesday3930
Alpha


and

Excel Workbook
ABCDE
1GroupNameNumberNextNumberFormula
2BetaThursday4940
3BetaFriday6960
4BetaSaturday6854
5BetaSunday909
6BetaMonday8764
7BetaTuesday2512
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?
 

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.
This does it:

Code:
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
 
Upvote 0
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...
 
Upvote 0
Was it the first or last? In which cell does your table begin? And which code did you run?
 
Last edited:
Upvote 0
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.
 
Upvote 0
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
ABCDEFGHIJKLMNOPQRSTUV
1Name1Series1Name3Name4Name5Series2Series3Series8Series9Name10Name11Name12Name13Series14Series15Series16Series17Name18Name19Name20Name21Name22
2TAOAYOGEXELYRHQNAP8559669949787955642023BLLGBUFRQBPXCQA
3OOREWDBRDUMPDSNAGG46941006257497114145198BLLUOMLIVHAZBXX
4ROYBRMVEJARDDDNTNS5385282830727855849BLLNNJLJXGSMSOX
5MQRVWNFYGLPJFXBAZW615297219664521318366BLLONEVBJFBXABK
6KUTOYEPKCYUZRUHD2426577377902944989270BLLTWNKBFQHVGQJ
7QYJGOVEJGLOTNBJTBX7783603522834092735942BLLBVXRTVBODGLU
8ABGBBIFPTVXZSTFRUI8266827510046857182298BLLCRIWJXNEUIGT
9PRGCDATXXVLYQUJQGZ428510454569203379866BLLHJRTOQWBJBFG
10VLTEOJOCQWBNFYBNEP2784358168961468292LQDNFRMQZDUYRZ
11SNHGLCFVUHMMJBKMHL6155475314310018504328QLUDLIMGHBRVKJX
12LIMEKXRINKAKDIHUKR8579519156176152569257IVOKBHRGOGLJCT
13BKQIQAGGZFVEMBPNLC707266721717167387484IVODTCHUMCTDJRY
14JKQRTOHWSMBDDYOVFZ3795464233947550832040IVOVKSTRMCGBPYE
15MJADJPLRXCUMJLCDJ9461858599811914369PBMMKHJRRLXQWFT
16CGBTIEVKLBBHBXJRKZ166229325964668563651OUHQYPMZQWWUGT
17FJFVCIAYUQBXGXNOVG185243612731610649934BDMNPSBGPAKMOBS
18UWQRLWGZGLREMPLIXV58456886218093458998BDMIEWMHJMOHOKO
19CPXGTXWBMDNTQIZJCE1897678773261393877BDMIAERHAUCIQBC
20HVREQOMHHQTMOBBLMW412637059152358919065PMMNCDNGPQHHHSM
21PMBHYMURJVIGVVQCOT8960364593962242647169PMMTPGVUGUQBTRE
Data


It split the sheet by the 8 names alphabetically. I can test another sample if you want.
 
Last edited:
Upvote 0

Forum statistics

Threads
1,224,828
Messages
6,181,217
Members
453,024
Latest member
Wingit77

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
Back
Top