Split a file based on filter on datarange

Oystein_Tvedten 

Here you go:

Sub SplitToFiles()
    Const h = 6               ' Header row
    Dim ws As Worksheet       ' Source sheet
    Dim r As Long             ' Row on source sheet
    Dim m As Long             ' Last data row
    Dim wb As Workbook        ' New workbook
    Dim wt As Worksheet       ' New worksheet
    Dim col As New Collection ' Unique leaders
    Dim v As Variant          ' Leader
    Dim p As String           ' Path
    Application.ScreenUpdating = False
    p = ThisWorkbook.Path & Application.PathSeparator
    Set ws = ActiveSheet
    m = ws.Range("A" & h).End(xlDown).Row
    On Error Resume Next
    For r = h + 1 To m
        col.Add Item:=ws.Range("A" & r).Value, Key:=ws.Range("A" & r).Value
    Next r
    On Error GoTo 0
    For Each v In col
        ws.Copy
        Set wb = ActiveWorkbook
        Set wt = wb.Worksheets(1)
        wt.Range("B1").Value = v
        wt.Range("A" & h).CurrentRegion.AutoFilter Field:=1, Criteria1:="<>" & v
        wt.Range("A" & h + 1 & ":A" & m).EntireRow.Delete
        wt.Range("A" & h).CurrentRegion.AutoFilter
        wb.SaveAs Filename:=p & v & ".xlsx", FileFormat:=xlOpenXMLWorkbook
        wb.Close SaveChanges:=False
    Next v
    Application.ScreenUpdating = True
End Sub