Sub ertert()
Dim x, i&, sPath$
With Application
    .ScreenUpdating = False: .DisplayAlerts = False
End With
x = Sheets("Sheet1").Range("A1").CurrentRegion.Value

With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 2 To UBound(x)
        If Not .Exists(x(i, 1)) Then .Item(x(i, 1)) = 1
    Next i: x = .keys
End With
On Error Resume Next: Err.Clear
sPath = ThisWorkbook.Path & "\"
With Sheets("Sheet1")
    With .Range("A1").CurrentRegion
        .AutoFilter
        For i = 0 To UBound(x)
            .AutoFilter Field:=1, Criteria1:=x(i)
            .SpecialCells(12).Copy
            With Workbooks.Add
                .Sheets(1).Range("A1").Select: .Sheets(1).Paste
                .Sheets(1).Range("A1").CurrentRegion.Columns.AutoFit
                .SaveAs Filename:=sPath & x(i), FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                DoEvents: .Close
            End With
        Next i
        .AutoFilter
    End With
End With
With Application
    .CutCopyMode = False: .ScreenUpdating = True: .DisplayAlerts = True
End With
End Sub