Sub www()
    Dim i&, a, ws As Worksheet, sh As Worksheet, r As Range
    Set sh = Worksheets("Загальна база")
    a = sh.Range("a2:a" & sh.Cells(sh.Rows.Count, 1).End(xlUp).Row).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a)
            .Item(a(i, 1)) = a(i, 1)
        Next
        Application.ScreenUpdating = 0
        For Each a In .keys
            sh.Copy after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet: ws.Name = .Item(a)
            Set r = ws.Range("a1:a" & ws.Cells(ws.Rows.Count, 1).End(xlUp).Row)
            r.AutoFilter 1, "<>" & .Item(a)
            r.Offset(1).SpecialCells(12).EntireRow.Delete
            ws.AutoFilterMode = 0: ws.DrawingObjects.Delete
        Next
        Application.ScreenUpdating = -1
    End With
End Sub

Sub Рознести_у_різні_книги()

If MsgBox("Курсор має бути на першій клітинці з даними. Якщо так і є - натисніть ТАК, якщо ні - натисніть НІ і спробуйте знову", vbYesNo) = vbNo Then
Exit Sub
Else
Do Until n = 1
On Error Resume Next
strDate2 = CDate(InputBox("Введіть дату звіту у форматі: Число.Місяць.Рік"))
If strDate2 = "" Then
MsgBox ("Дата не введена. Помилка!"): Exit Sub
Else

If IsError(strDate2) = True Or Year(strDate2) <> Year(Now()) Then
n = 0
Else
strDate = Format(strDate2, "dd/mm/yy")
n = 1
End If
End If
strDate2 = ""
Loop

fold = "D:\Звіти обліківцям\"
Application.ScreenUpdating = False

rozn = Range(Range(Selection, Selection.End(xlToRight)), Selection.End(xlDown))
kryteriy = InputBox("Введіть номер стовпця, який містить критерій рознесення даних", "Критерій", DefaultValue, 1000, 1000)
If kryteriy = "" Then Exit Sub
spysok = UniqueValuesFromArray(rozn, kryteriy)
Kill fold & "*.xlsx"

  Range(Range(Selection, Selection.End(xlToRight)), Selection.End(xlDown)).AutoFilter
  For i = LBound(spysok) To UBound(spysok)
      ActiveSheet.Range(Range(Selection, Selection.End(xlToRight)), Selection.End(xlDown)).AutoFilter Field:=kryteriy, Criteria1:= _
        spysok(i, 1)
        Range(Range(Selection, Selection.End(xlToRight)), Selection.End(xlDown)).Copy
    Workbooks.Add(xlWBATWorksheet).Worksheets.Add Count:=1
    ActiveSheet.Paste
    ActiveSheet.ListObjects.Add(xlSrcRange, Range(Range("$A$1", Selection.End(xlToRight)), Selection.End(xlDown)), , xlYes).Name = _
        "Таблиця1"
    Columns("A:P").EntireColumn.AutoFit
    
ActiveWorkbook.SaveAs (fold & spysok(i, 1) & " " & strDate & ".xlsx")
ActiveWorkbook.Close

Next i
' If user has clicked Cancel, set myValue to defaultValue
'If kryteriy Is "" Then myValue = DefaultValue
End If

Application.ScreenUpdating = True
If MsgBox("Файли успішно створено. Перейти до папки з файлами?", vbYesNo) = vbYes Then

   
Shell "explorer.exe " & fold, vbMaximizedFocus

   End If
End Sub


Function UniqueValuesFromArray(ByVal arr, ByVal col As Long) As Variant
    ' перебирает все значения в столбце Col двумерного массива arr
   ' в поисках уникальных значений. Возвращает двумерный вертикальный массив
   ' размерностью N * 1, содержащий уникальные значения из столбца col
   If Not IsArray(arr) Then MsgBox "Это не массив!", vbCritical: Exit Function
    If col > UBound(arr, 2) Then MsgBox "Немає такого стовпця в масиві!", vbCritical: Exit Function
    If col < LBound(arr, 2) Then MsgBox "Немає такого стовпця в масиві!", vbCritical: Exit Function

    On Error Resume Next: Dim coll As New Collection, txt$
    For i = LBound(arr) + 1 To UBound(arr)
        txt$ = Trim(arr(i, col)): coll.Add txt$, txt$
    Next i
    ReDim newarr(1 To coll.Count, 1 To 1)
    For i = 1 To coll.Count: newarr(i, 1) = coll(i): Next i
    UniqueValuesFromArray = newarr
End Function