Sub SplitTable()

'Разностит DB по листам с условием в столбце "ГОРОД РОЖДЕНИЯ" (частный случай)
'http://planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=59002

col_name=InputBox ("Введите название столбца-критерия на данном листе")
If col_name = "" Then End
On Error Exit Sub

StartChName=ActiveSheet.Name


With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
On Error Resume Next
    spCol = StartChName.UsedRange.Find("col_name").Column
    lRow = Cells(Rows.Count, spCol).End(xlUp).Row
    For Each cl In Range(Cells(2, spCol), Cells(lRow, spCol)).Cells
        flag = 0
        For Each Sh In Worksheets
            If Sh.Name = cl.Value Then
                Set DesSh = Sh
                flag = 1
                Exit For
            End If
        Next
        If flag = 0 Then
            Sheets.Add After:=Sheets(Sheets.Count)
            With ActiveSheet
                .Name = cl.Value
                Sheets("StartChName").Rows("1:3").Copy Destination:=.Range("A1")
            End With
            Set DesSh = ActiveSheet
        End If
        With DesSh
            Sheets("StartChName").Rows(cl.Row).Copy Destination:=.Rows(.Cells(Rows.Count, 1).End(xlUp).Row + 1)
            .Columns("A:D").EntireColumn.AutoFit
        End With
        Sheets("StartChName").Activate
    Next
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
End Sub