Sub mrshkei()
Dim col As New Collection, arr, i As Long, n As Long, lr As Long, cell As Range
With Worksheets("База")
arr = .Range("A2:N2")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = Sheets.Count To 1 Step -1
t = Worksheets(i).Name
    If t <> "База" Then Worksheets(i).Delete
Next i
Application.DisplayAlerts = True
lr = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To lr
    On Error Resume Next
    col.Add .Cells(i, 6), CStr(.Cells(i, 6))
    i = i + 50
   Next i
For n = 1 To col.Count
    For i = 1 To Sheets.Count
        If col(n) = Worksheets(i).Name Then x = x + 1
    Next i
    If x = 0 And n <= Sheets.Count Then
    Worksheets.Add after:=Worksheets(Worksheets.Count)
    Worksheets(Worksheets.Count).Name = col(n)
    ActiveSheet.Range("A1").Resize(1, 14) = arr
    x = 0
    End If
Next n
    For i = 1 To Sheets.Count
    If Worksheets(i).Name <> "База" Then
        Worksheets(i).Range("A2:N10000").Clear
        For n = 3 To lr
            If .Cells(n, 6) = Worksheets(i).Name Then
                If cell Is Nothing Then
                    Set cell = .Cells(n, 6)
                Else
                    Set cell = Union(cell, .Cells(n, 6))
                End If
            End If
        Next n
        If Not cell Is Nothing Then cell.EntireRow.Copy Destination:=Worksheets(i).Range("A2")
        Set cell = Nothing
    End If
    Next i
End With
Application.ScreenUpdating = True
End Sub