Split Data into Multiple Workbook

Hi,

Many times we need to make category wise separate files  from data on a worksheet, here is code that will do it for you.

Here i have a scenario ,Suppose  we have some data in a Range and 2nd Column of Range have some Categories , we want to bifurcate all Record of all Categories in different Excel Files.

Follow the  some simple Steps To Bifurcate the data with in multiple workbook, Original data will remain same.

1) Create a Name of First Cell of Data Range as "rngStart"

2) Create a Name range of First cell on another blank worksheets  as "rngRemoveDuplicate"

3) Copy Paste this Code in VBA Module 

4) Run the Macro

Note : This will save all bifurcated data file at same location where the MainData File is saved. So you can make a separate folder and can save Main Data file in that folder.

Sub SplitAllbyCode()

   

    Dim rngRange    As Range

    Dim wksSheet    As Worksheet

    Dim ArrUniqe

    Dim lngUniqeCount As Long

    Dim wbkNew          As Workbook

   

    Set wksSheet = ThisWorkbook.Worksheets("Sheet1")

    With wksSheet

        Set rngRange = Intersect(Range("rngStart").CurrentRegion, Range("rngStart").CurrentRegion.Offset(2))

        Application.ScreenUpdating = False

        rngRange.Columns(4).Copy Range("rngRemoveDuplicate")

        Range("rngRemoveDuplicate").CurrentRegion.RemoveDuplicates 1

        ArrUniqe = Range("rngRemoveDuplicate").CurrentRegion

        For lngUniqeCount = LBound(ArrUniqe) To UBound(ArrUniqe)

            Range("rngStart").CurrentRegion.Rows(2).AutoFilter 4, ArrUniqe(lngUniqeCount, 1)

            Range("rngStart").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy

            Set wbkNew = Workbooks.Add

            wbkNew.Worksheets(1).Paste

            wbkNew.SaveAs ThisWorkbook.Path & "\" & ArrUniqe(lngUniqeCount, 1)

            wbkNew.Close 1

        Next lngUniqeCount

    End With

        wksSheet.AutoFilterMode = False

        Application.ScreenUpdating = True

        Range("rngRemoveDuplicate").CurrentRegion.ClearContents

       MsgBox lngUniqeCount & "  Files has been splited, Plase find your files at " & vbCrLf & ThisWorkbook.Path

'Free Memory

Set rngRange = Nothing

Set wksSheet = Nothing

Erase ArrUniqe

Set wbkNew = Nothing

End Sub

Thanks for Reading