Option Explicit
Sub razdelit()
Dim oDic As Object, arr(), arWB(), j As Long, wbOld As Workbook
Dim sh As Worksheet, i As Long, cnt As Long, k As Long, wb As Workbook
Set wbOld = ThisWorkbook
For Each sh In Worksheets
arr = sh.UsedRange.Value
Set oDic = CreateObject("scripting.dictionary")
For i = 3 To UBound(arr)
oDic.Item(arr(i, 1)) = arr(i, 1)
Next
Next
arWB = oDic.items
Set oDic = Nothing
ReDim arrData(1 To UBound(arr), 1 To UBound(arr, 2))
    For i = 1 To UBound(arWB)
    Set wb = Workbooks.Add
    wb.SaveAs "D:\test" & "\" & arWB(i) & ".xlsx" 'ïóòü ñîõðàíåíèÿ ôàéëîâ
    Set wb = ActiveWorkbook
    For Each sh In wbOld.Worksheets
    cnt = 0
    arr = sh.UsedRange.Value
        For j = 3 To UBound(arr)
            If arr(j, 1) = arWB(i) Then
                cnt = cnt + 1
                For k = 1 To UBound(arr, 2)
                arrData(cnt, k) = arr(j, k)
                Next
            End If
        Next
    wb.Sheets.Add.Name = sh.Name
    wb.Sheets(sh.Name).[a1].Resize(cnt, UBound(arr, 2)) = arrData
    Next
    wb.Close True
    Next
End Sub