Split Excel by a column criteria

%3CLINGO-SUB%20id%3D%22lingo-sub-2969716%22%20slang%3D%22en-US%22%3ESplit%20Excel%20by%20a%20column%20criteria%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-2969716%22%20slang%3D%22en-US%22%3E%3CP%3EI%20have%20a%20sheet%20with%20the%20following%20columns%3A%3C%2FP%3E%3CTABLE%20width%3D%222225%22%3E%3CTBODY%3E%3CTR%3E%3CTD%20width%3D%22187%22%3EPath%20ID%3C%2FTD%3E%3CTD%20width%3D%22290%22%3EOwner%20Name%3C%2FTD%3E%3CTD%20width%3D%22273%22%3EOwner%20Login%3C%2FTD%3E%3CTD%20width%3D%22106%22%3EItem%20Type%3C%2FTD%3E%3CTD%20width%3D%2269%22%3ESize%3C%2FTD%3E%3CTD%20width%3D%2292%22%3ECreated%3C%2FTD%3E%3CTD%20width%3D%22130%22%3ELast%20Modified%3C%2FTD%3E%3CTD%20width%3D%22104%22%3EUploaded%3C%2FTD%3E%3CTD%20width%3D%22659%22%3EPath%3C%2FTD%3E%3CTD%20width%3D%22121%22%3EFolder%20Level%3C%2FTD%3E%3CTD%20width%3D%22104%22%3EORG%20UNIT%3C%2FTD%3E%3CTD%20width%3D%2290%22%3EONEDR%2FSHAREPOINT%3C%2FTD%3E%3C%2FTR%3E%3C%2FTBODY%3E%3C%2FTABLE%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EThe%20sheet%20contains%203780%20record%2C%20I%20want%20to%20split%20this%20excel%20into%20many%20excel%20based%20on%20the%20Owner%20Name%20and%20the%20generated%20excel%20will%20be%20named%20by%20the%20owner%20name%20and%20saved%20in%20a%20specific%20folder.%20Does%20anyone%20can%20help%20with%20this%20code%3F%3C%2FP%3E%3C%2FLINGO-BODY%3E%3CLINGO-LABS%20id%3D%22lingo-labs-2969716%22%20slang%3D%22en-US%22%3E%3CLINGO-LABEL%3EMacros%20and%20VBA%3C%2FLINGO-LABEL%3E%3C%2FLINGO-LABS%3E%3CLINGO-SUB%20id%3D%22lingo-sub-2969888%22%20slang%3D%22en-US%22%3ERe%3A%20Split%20Excel%20by%20a%20column%20criteria%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-2969888%22%20slang%3D%22en-US%22%3E%3CP%3E%3CA%20href%3D%22https%3A%2F%2Ftechcommunity.microsoft.com%2Ft5%2Fuser%2Fviewprofilepage%2Fuser-id%2F1220123%22%20target%3D%22_blank%22%3E%40RMedair%3C%2FA%3E%26nbsp%3B%3C%2FP%3E%0A%3CP%3EHere%20you%20go%3A%3C%2FP%3E%0A%3CPRE%20class%3D%22lia-code-sample%20language-visual-basic%22%3E%3CCODE%3ESub%20SplitData()%0A%20%20%20%20'%20Target%20path%2C%20must%20end%20in%20%5C%0A%20%20%20%20Const%20strPath%20%3D%20%22C%3A%5CExcel%5C%22%0A%20%20%20%20'%20Column%20with%20Owner%20Names%0A%20%20%20%20Const%20NameCol%20%3D%202%20'%20column%20B%0A%20%20%20%20'%20Variables%0A%20%20%20%20Dim%20wshS%20As%20Worksheet%0A%20%20%20%20Dim%20wbkT%20As%20Workbook%0A%20%20%20%20Dim%20wshT%20As%20Worksheet%0A%20%20%20%20Dim%20lngLast%20As%20Long%0A%20%20%20%20Dim%20arr()%0A%20%20%20%20Dim%20r%20As%20Long%0A%20%20%20%20Dim%20col%20As%20Collection%0A%20%20%20%20Dim%20itm%0A%20%20%20%20'%20Turn%20off%20screen%20updating%20temporarily%0A%20%20%20%20Application.ScreenUpdating%20%3D%20False%0A%20%20%20%20'%20Refer%20to%20activesheet%0A%20%20%20%20Set%20wshS%20%3D%20ActiveSheet%0A%20%20%20%20'%20Last%20used%20row%0A%20%20%20%20lngLast%20%3D%20wshS.Cells(wshS.Rows.Count%2C%20NameCol).End(xlUp).Row%0A%20%20%20%20'%20Load%20values%20of%20name%20column%20into%20array%0A%20%20%20%20arr%20%3D%20wshS.Range(wshS.Cells(1%2C%20NameCol)%2C%20wshS.Cells(lngLast%2C%20NameCol)).Value%0A%20%20%20%20'%20Create%20collection%20of%20unique%20names%0A%20%20%20%20Set%20col%20%3D%20New%20Collection%0A%20%20%20%20On%20Error%20Resume%20Next%0A%20%20%20%20For%20r%20%3D%202%20To%20lngLast%0A%20%20%20%20%20%20%20%20col.Add%20Item%3A%3Darr(r%2C%201)%2C%20Key%3A%3DCStr(arr(r%2C%201))%0A%20%20%20%20Next%20r%0A%20%20%20%20On%20Error%20GoTo%200%0A%20%20%20%20'%20Loop%20through%20the%20collection%0A%20%20%20%20For%20Each%20itm%20In%20col%0A%20%20%20%20%20%20%20%20'%20Create%20new%20workbook%20with%20one%20sheet%0A%20%20%20%20%20%20%20%20Set%20wbkT%20%3D%20Workbooks.Add(Template%3A%3DxlWBATWorksheet)%0A%20%20%20%20%20%20%20%20Set%20wshT%20%3D%20wbkT.Worksheets(1)%0A%20%20%20%20%20%20%20%20'%20Filter%20the%20data%0A%20%20%20%20%20%20%20%20wshS.UsedRange.AutoFilter%20Field%3A%3DNameCol%2C%20Criteria1%3A%3Ditm%0A%20%20%20%20%20%20%20%20'%20Copy%20to%20new%20workbook%0A%20%20%20%20%20%20%20%20wshS.UsedRange.Copy%20Destination%3A%3DwshT.Cells(1%2C%201)%0A%20%20%20%20%20%20%20%20wbkT.SaveAs%20Filename%3A%3DstrPath%20%26amp%3B%20itm%20%26amp%3B%20%22.xlsx%22%2C%20FileFormat%3A%3DxlOpenXMLWorkbook%0A%20%20%20%20%20%20%20%20'%20Save%20and%20close%20new%20workbook%0A%20%20%20%20%20%20%20%20wbkT.Close%20SaveChanges%3A%3DFalse%0A%20%20%20%20Next%20itm%0A%20%20%20%20'%20Clean%20up%0A%20%20%20%20wshS.UsedRange.AutoFilter%0A%20%20%20%20Application.CutCopyMode%20%3D%20False%0A%20%20%20%20Application.ScreenUpdating%20%3D%20True%0AEnd%20Sub%3C%2FCODE%3E%3C%2FPRE%3E%3C%2FLINGO-BODY%3E
Visitor

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