Split Excel by a column criteria

New Contributor

I have a sheet with the following columns:

Path IDOwner NameOwner LoginItem TypeSizeCreatedLast ModifiedUploadedPathFolder LevelORG UNITONEDR/SHAREPOINT

 

The sheet contains 3780 record, I want to split this excel into many excel based on the Owner Name and the generated excel will be named by the owner name and saved in a specific folder. Does anyone can help with this code?

1 Reply

@RMedair 

Here you go:

Sub SplitData()
    ' Target path, must end in \
    Const strPath = "C:\Excel\"
    ' Column with Owner Names
    Const NameCol = 2 ' column B
    ' Variables
    Dim wshS As Worksheet
    Dim wbkT As Workbook
    Dim wshT As Worksheet
    Dim lngLast As Long
    Dim arr()
    Dim r As Long
    Dim col As Collection
    Dim itm
    ' Turn off screen updating temporarily
    Application.ScreenUpdating = False
    ' Refer to activesheet
    Set wshS = ActiveSheet
    ' Last used row
    lngLast = wshS.Cells(wshS.Rows.Count, NameCol).End(xlUp).Row
    ' Load values of name column into array
    arr = wshS.Range(wshS.Cells(1, NameCol), wshS.Cells(lngLast, NameCol)).Value
    ' Create collection of unique names
    Set col = New Collection
    On Error Resume Next
    For r = 2 To lngLast
        col.Add Item:=arr(r, 1), Key:=CStr(arr(r, 1))
    Next r
    On Error GoTo 0
    ' Loop through the collection
    For Each itm In col
        ' Create new workbook with one sheet
        Set wbkT = Workbooks.Add(Template:=xlWBATWorksheet)
        Set wshT = wbkT.Worksheets(1)
        ' Filter the data
        wshS.UsedRange.AutoFilter Field:=NameCol, Criteria1:=itm
        ' Copy to new workbook
        wshS.UsedRange.Copy Destination:=wshT.Cells(1, 1)
        wbkT.SaveAs Filename:=strPath & itm & ".xlsx", FileFormat:=xlOpenXMLWorkbook
        ' Save and close new workbook
        wbkT.Close SaveChanges:=False
    Next itm
    ' Clean up
    wshS.UsedRange.AutoFilter
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub