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

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

Select allOpen in new window

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

Select allOpen in new window

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