Split a file based on filter on datarange

[Oystein_Tvedten]

Hi,

I have a file which has filler lines on top and bottom of a a defined datarange/dataset. 
What I would like to do is run a macro or script to filter through each value in Column A (Leader, see attached file) of the named range, and then save each result in a new file (named Review-LeaderValue.xlsx for example, where the "LeaderValue" is the resulting value in the filter of column A).

Also, I'd like put the now unique value in the Leader Column into cell B1. 

I've attached an example file of how it looks - and it has two sheets. "Dataset" to show how the original would look and "Example Outcome" to show what I want to try to achieve. 

If it was just a pure dataset it would be easier to accomodate, but as I need to retain the lines above and below the set I am a tad lost. 

Øystein

[#2 · Accepted solution]

@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

[#3]

Perfect! Thanks a bunch! :D