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

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

 http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28639974.html#a40678947

...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!
K.B.

2015-04-16-1829.png
LVL 9
K BAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Roy CoxGroup Finance ManagerCommented:
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
        .Columns(.Columns.Count).Clear
        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
                Sheets(sNm).Cells.Clear
            Else
                '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

'
'
K BAuthor Commented:
Thank you for your reply Roy!  
Attached is the sample spreadsheet.
Sample-EE-2015-04-16.xlsx
Roy CoxGroup Finance ManagerCommented:
We need to get rid of the duplicated bold entries, will this be OK?
Angular Fundamentals

Learn the fundamentals of Angular 2, a JavaScript framework for developing dynamic single page applications.

Saurabh Singh TeotiaCommented:
Kevin,

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)
            Else
                ActiveSheet.Name = cell.Offset(1, 0).Value
            End If

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

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

    Next cell

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

Open in new window


Your workbook...

Saurabh...
Sample-EE-2015-04-16.xlsm
Roy CoxGroup Finance ManagerCommented:
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
Sample-EE-2015-04-16.xlsm
K BAuthor Commented:
Saurabh,

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).
Saurabh Singh TeotiaCommented:
Kevin,

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

Saurabh...
K BAuthor Commented:
Saurabh,

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

Kevin
Saurabh Singh TeotiaCommented:
Use this code...

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
    Dim i 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
        
        If Not ws1 Is Nothing Then ws1.Name = ws1.Name & " No. of Rows->" & i

            Sheets.Add after:=Sheets(Sheets.Count)
            
                ActiveSheet.Name = Left(cell.Offset(1, 0).Value, 10)
         

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

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

    Next cell
    
     If Not ws1 Is Nothing Then ws1.Name = ws1.Name & " No. of Rows->" & i

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

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
K BAuthor Commented:
Perfection!
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.