Link to home
Create AccountLog in
Avatar of K B
K BFlag for United States of America

asked on

Create worksheets from single Excel worksheet (based on column c)

I am trying to build off this great work...

...or your own code is fine too.
Need to create new tabs in excel based on a column (c in this example)
anywhere from 20,000 rows to 350,000 rows of data
I would like the header rows to follow the data.
Would love if each tab was named the respective name from column C plus number of rows (on that tab).
Each header row starts with DisplayName in the first column
I have attached an image and a sample .xlsx file.

Thank you for your time in advance!

User generated image
Avatar of Roy Cox
Roy Cox
Flag of United Kingdom of Great Britain and Northern Ireland image

Your source data is not set out for efficient use. Data should be stored with only one header row. This code will work if the data is laid out correctly. Note: there does not seem to be an attached workbook, add one and I'll see if I can change the code.

Option Explicit

' Module    : Module1
' DateTime  : 24/09/2006 22:48
' Updated   : 2014
' Author    : Roy Cox (royUK)
' Website   :  more examples
' Purpose   :  Create a sheet for each unique name in data
' Disclaimer; This code is offered as is with no guarantees. You may use it in your
'             projects but please leave this header intact.

Sub ExtractToSheets()
    Dim ws     As Worksheet
    Dim wsNew  As Worksheet
    Dim rData  As Range
    Dim rCl    As Range
    Dim sNm    As String
    Set ws = Sheet1

    'extract a list of unique names
    'first clear existing list
    With ws
        Set rData = .Range("A1").CurrentRegion
        rData.Columns(3).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True

        For Each rCl In .Cells(1, .Columns.Count).CurrentRegion
            sNm = rCl.Text
            'add new sheet (only if required-NB uses UDF)
            If WksExists(sNm) Then
                'so clear contents
                'new sheet required
                Set wsNew = Sheets.Add
                wsNew.Move After:=Worksheets(Worksheets.Count)    'move to end
                wsNew.Name = sNm
            End If
            'AutoFilter & copy to relevant sheet
            rData.AutoFilter Field:=3, Criteria1:=sNm
            rData.Copy Destination:=Worksheets(sNm).Cells(1, 1)
        Next rCl
    End With
    ws.Columns(Columns.Count).ClearContents        'remove temporary list
    rData.AutoFilter        'switch off AutoFilter
End Sub

Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

Open in new window

Avatar of K B


Thank you for your reply Roy!  
Attached is the sample spreadsheet.
We need to get rid of the duplicated bold entries, will this be OK?

You can use the following code it will do what you are looking for.. Also sheet name can't be more then 31 characters so i have trimmed them to be 31 characters.. In additional i have assumed accountsku is the header row and from their the new data starts...

Sub createsheetabs()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim rng As Range, cell As Range
    Dim ws As Worksheet, lrow As Long, wk As Worksheet
    Dim lr As Long, ws1 As Worksheet, srow As Long

    Set ws = Sheets("Sheet1")

    For Each wk In ActiveWorkbook.Worksheets
        If wk.Name <> ws.Name Then wk.Delete

    Next wk

    lrow = ws.Cells(Cells.Rows.Count, "A").End(xlUp).Row

    Set rng = ws.Range("C1:C" & lrow)

    For Each cell In rng

        If InStr(1, cell.Value, "AccountSku", vbTextCompare) > 0 Then

            Sheets.Add after:=Sheets(Sheets.Count)
            If Len(cell.Offset(1, 0).Value) > 31 Then
                ActiveSheet.Name = Left(cell.Offset(1, 0).Value, 31)
                ActiveSheet.Name = cell.Offset(1, 0).Value
            End If

            Set ws1 = ActiveSheet
            cell.EntireRow.Copy ws1.Range("a1")

            lr = ws1.Cells(Cells.Rows.Count, "c").End(xlUp).Row + 1
            cell.EntireRow.Copy ws1.Range("A" & lr)
        End If

    Next cell

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Open in new window

Your workbook...

See if this is OK

The code first clears the unnecessary lines, then creates a list of unique entries. using this list it will create sheets for each entry, checking for bad caharacters and length of sheet name
Avatar of K B



Thank you!!!
Awesome as always!  
One little thing... could each tab name include the number of rows per...

Would love if each tab was named the respective name from column C plus number of rows (on that tab).

Where do you want to see that row count..? In which cell of the created worksheet??

Avatar of K B



Included in the name of the tab.
I know they are already pretty long :-)

Avatar of Saurabh Singh Teotia
Saurabh Singh Teotia
Flag of India image

Link to home
Create an account to see this answer
Signing up is free. No credit card required.
Create Account
Avatar of K B