Option Explicit

Sub Split_WB()
    Dim c As Range, k As Variant

    Dim ws          As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With

    With ThisWorkbook.Worksheets("Sheet1")

        Dim rg      As Range
        Set rg = .Range("D6:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
    End With

    With CreateObject("Scripting.Dictionary")

        For Each c In rg
            .Item(c.Value) = Empty
        Next c

        For Each k In .keys

            Dim wb  As Workbook
            Set wb = Workbooks.Add

            With ws
                .Cells(6, 4).CurrentRegion.AutoFilter Field:=1, Criteria1:=k
                .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy

                Dim wsNew As Worksheet
                Set wsNew = wb.Sheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))

                With wsNew
                    .Name = k
                    .Cells(1).PasteSpecial xlPasteAll
                End With

                .AutoFilterMode = False
            End With

            wb.Worksheets(1).Delete
            wb.SaveAs ThisWorkbook.Path & "\" & k & ".xlsx"
            wb.Close False
        Next k

    End With

    Set wsNew = Nothing
    Set wb = Nothing
    Set rg = Nothing
    Set ws = Nothing

    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With

    MsgBox " Шеф, Усё, Клиент готов! "
End Sub