Forum Discussion

Oystein_Tvedten's avatar
Oystein_Tvedten
Copper Contributor
Aug 28, 2021
Solved

Split a file based on filter on datarange

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

excel
Macros and VBA
  • HansVogelaar's avatar
    HansVogelaar
    Aug 28, 2021

    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

2 Replies

  • HansVogelaar's avatar
    HansVogelaar
    MVP
    Aug 28, 2021

    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

Resources