Option Explicit

Function Level(Optional cCell As Range)
    Application.Volatile
    ' LEVEL returns the outline level of the current row. It will not automatically update and therefore
    ' a recalculation Ctrl-Alt-F9 is required.
    '
    'SYNTAX
    ' =level()

    'EXAMPLE
    ' Let the outline level of the row be 1, =level() returns 1.
    '
    ' Author: Andrew O'Connor <andrew.oconnor@relken.com>
    ' Date: 23 Apr 2013
    ' Copyright: 2014 Relken Engineering

    If cCell Is Nothing Then
        Set cCell = Application.Caller
    End If
    Level = cCell.Rows.OutlineLevel

End Function
Function WorksheetExist(wsname As String) As Boolean
'Возвращает ИСТИНА, если лист существует
    Dim x As Worksheet
    On Error Resume Next
    Set x = Worksheets(wsname)
    WorksheetExist = (Err = 0)
End Function


Public Sub www()
    Dim a, ws As Worksheet, r As Range, lr&
    Application.ScreenUpdating = 0
    With Sheets("TDSheet")
        .AutoFilterMode = 0
        Set r = .Range("c10:c" & [c65536].End(xlUp).Row)
        r.Offset(, 1).Formula = "=Level()"
        r.Offset(, 1).AutoFilter field:=1, Criteria1:=5
        .Calculate
        For Each a In r.Offset(1).SpecialCells(12).Areas
            If WorksheetExist(.Cells(a.Row - 1, 2).Value) Then
                Set ws = Sheets(.Cells(a.Row - 1, 2).Value)
                lr = Sheets(.Cells(a.Row - 1, 2).Value).[c65536].End(xlUp).Row + 1
                a.EntireRow.Copy ws.Cells(lr, 1)
                ws.[2:3].EntireColumn.AutoFit
            Else
                Set ws = Worksheets.Add
                ws.Name = .Cells(a.Row - 1, 2).Value
                a.EntireRow.Copy ws.[a1]
                ws.[2:3].EntireColumn.AutoFit
            End If
        Next
        .AutoFilterMode = 0
    End With
    Application.ScreenUpdating = -1
End Sub