[/CODE]Sub SplitSheets2()
    Dim s As Worksheet
    Dim wb as Workbook
    Set wb = ActiveWorkbook
    For Each s In wb.Worksheets                                'проходим во всем листам активной книги
        s.Copy                                                 'сохраняем лист как новый файл
        ActiveWorkbook.SaveAs wb.Path & "\" & s.Name & ".xls"  'сохраняем файл
    Next

End Sub[CODE]

Sub test()
Dim arrInp(), arrKey(), arrOut()
Dim i As Long, j As Long, k As Long, l As Long
arrInp = Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 17)).Value

With CreateObject("Scripting.Dictionary")
    For i = LBound(arrInp, 1) + 1 To UBound(arrInp, 1)
        .Item(arrInp(i, 5)) = .Item(arrInp(i, 5)) + 1
    Next i
    arrKey = .Keys
    For i = LBound(arrKey) To UBound(arrKey)
        l = 0
        ReDim arrOut(LBound(arrInp, 1) To .Item(arrKey(i)) + 1, LBound(arrInp, 2) To UBound(arrInp, 2))
        
        For j = LBound(arrInp, 1) To UBound(arrInp, 1)
            If (j = LBound(arrInp, 1)) Or (arrKey(i) = arrInp(j, 5)) Then
                l = l + 1
                For k = LBound(arrInp, 2) To UBound(arrInp, 2)
                    arrOut(l, k) = arrInp(j, k)
                Next k
            End If
        Next j
        On Error Resume Next
        Worksheets.Add After:=Worksheets(Worksheets.Count)
        With ActiveSheet
            .Name = arrKey(i)
            .Cells(1).Resize(UBound(arrOut, 1) - LBound(arrOut, 1) + 1, _
            UBound(arrOut, 2) - LBound(arrOut, 2) + 1).Value = arrOut
            .Range(.Cells(2, 3), .Cells(.Rows.Count, 3).End(xlUp)).NumberFormat = "[$-F400]h:mm:ss AM/PM"
            .UsedRange.EntireColumn.AutoFit
        End With
    Next i
End With
End Sub