Macro to split one file into many based on criteria

[Alka Bajaj]

Hi Expert,

I have a file, with this dummy data
Fruit Country QTy
Apple India 100
Apple USA 200
Orange India 150
Grapes Aus 100
Grapes India 100

I need to macro, wherby it will create 3 files namely apple, orange,grapes and store the relevant rows.

Hence I need a macro to split file into different files based on different values in a column and accordingly name it .

Appreciate your guidance and help on this.

Many thanks.
Regards,
Alka Bajaj

 

[jbeaucaire]

'SHEET1 TO MANY WORKBOOKS
Here's a macro for parsing rows of data from one sheet to many workbooks named for the same values.

Sheet1 to Many Workbooks​

My macro names the workbooks for values in the column PLUS today's date, you can take a stab at removing the date part...or leave it in, it's a good technique.

Edit the macro to the correct name for your data sheet and the SvPath where you want the files created to be save into.

 

[Sektor]

Sub SplitFile()

    Dim i As Long
    Dim arrFruits As Variant, arrBooks() As Workbook
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Sheet1.AutoFilterMode = False
    
    arrFruits = Array("Apple", "Orange", "Grapes")
    ReDim arrBooks(0 To UBound(arrFruits))
    
    ' Create workbooks.
    For i = 0 To UBound(arrFruits)
        Set arrBooks(i) = Workbooks.Add
    Next
    
    ' Retrieve data by autofilter.
    With Sheet1
        For i = 0 To UBound(arrFruits)
            .Range("A1:A3").AutoFilter Field:=1, Criteria1:=arrFruits(i)
            .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
            Workbooks(arrBooks(i).Name).Sheets(1).Range("A1").PasteSpecial
        Next
    End With

    ' Save all workbooks.
    For i = 0 To UBound(arrBooks)
        Workbooks(arrBooks(i).Name).SaveAs Filename:=ThisWorkbook.Path & "\" & arrFruits(i) & ".xlsx"
    Next

    ' Clean-up.
    Application.ScreenUpdating = False
    Sheet1.AutoFilterMode = False
    Application.DisplayAlerts = True

End Sub

 

[Alka Bajaj]

Hi Jbeaucaire

With reference to
Sheet1 to Many Workbooks

Following is my code, but the split file only displays the header, the rows are not getting added to the required files.
Appreciate your help on this

Sub ParseItems()
'Jerry Beaucaire  (4/22/2010)
'Based on selected column, data is filtered to individual workbooks
'workbooks are named for the value plus today's date
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String
Application.ScreenUpdating = False
'Column to evaluate from, column A = 1, B = 2, etc.
   vCol = 9
'Sheet with data in it
   Set ws = Sheets("ACT report")
'Path to save files into, remember the final \
    SvPath = "C:\xyz\"
'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
    vTitles = "A1:Z1"
 
'Spot bottom row of data
   LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row
'Get a temporary list of unique values from column A
    ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True
'Sort the temporary list
    ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _
       OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'Put list into an array for looping (values cannot be the result of formulas, must be constants)
    MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))
'clear temporary worksheet list
    ws.Range("EE:EE").Clear
'Turn on the autofilter, one column only is all that is needed
    ws.Range(vTitles).AutoFilter
'Loop through list one value at a time
    For Itm = 1 To UBound(MyArr)
        ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)
       
        ws.Range("A1:A" & LR).EntireRow.Copy
        Workbooks.Add
        Range("A1").PasteSpecial xlPasteAll
        Cells.Columns.AutoFit
        MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 1
       
        ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, " MM-DD-YY"), xlNormal
        ActiveWorkbook.Close False
       
        ws.Range(vTitles).AutoFilter Field:=vCol
    Next Itm
'Cleanup
    ws.AutoFilterMode = False
    MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Hope they match!!"
    Application.ScreenUpdating = True
End Sub

 

[aravindhan_31]

Hi,

this code will create sheets for you. Let me know if you want to create separate files
I am assuming that you have Fruites in Column A, Country in B & Qty in C.

Sub Create_Sheets()
Dim sWS     As Worksheet
Dim Fruitss As Range, Fruits    As Range
Dim lRow    As Long, fRow       As Integer
Dim CopyRng As Range, ws        As Worksheet
Set sWS = Worksheets("Data")
lRow = sWS.Range("A" & Rows.Count).End(xlUp).Row
    Application.ScreenUpdating = False
    sWS.Columns(1).Insert
    sWS.Range("B1:B" & lRow).AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=sWS.Range("A1"), Unique:=True
fRow = sWS.Range("A" & Rows.Count).End(xlUp).Row
Set Fruitss = sWS.Range("A2:A" & fRow)
    For Each Fruits In Fruitss
        With sWS.Range("B1:B" & lRow)
            .AutoFilter Field:=1, Criteria1:=Fruits
            Set CopyRng = .Offset(0, 0).Resize(.Rows.Count + 1, Columns.Count - 1). _
                SpecialCells(xlCellTypeVisible)
            On Error Resume Next
            Set ws = Sheets(Fruits.Value)
            On Error GoTo 0
            If Not ws Is Nothing Then
                CopyRng.Copy
                ws.Range("A1").PasteSpecial xlPasteAll
            
                'ws.Cells(Rows.Count, 9).End(xlUp).Font.Bold = True
            Else
                Set ws = Sheets.Add
                ws.Name = Fruits.Value
                CopyRng.Copy
                ws.Range("A1").PasteSpecial xlPasteAll
               ' ws.Cells(Rows.Count, 9).End(xlUp).Font.Bold = True
            End If
            .AutoFilter
        End With
        Set ws = Nothing
        Set CopyRng = Nothing
    Next Fruits
    sWS.Columns(1).Delete
    Sheets("Data").Select
   End Sub

 

[Krishnakumar]

Hi,

Or you may try Unique Data into Multiple Workbooks as well.

 

[bunbury]

I need help with the naming of the new files portion of the code.

I have the following data:
AAA Jan
AAA Feb
AAA Mar
BBB Apr
BBB May
CCC Feb
CCC Mar
CCC Apr
CCC May
etc

when splitting into multiple workbooks, I want to save as AAA Jan-Mar.xls and BBB Apr-May.xls and CCC Feb-May.xls and so on and so forth depending on the min and max of the month range within. is that possible?

I have already coverted the month column into text.

or is there a formula that I can use in the worksheet itself to get a 3rd column which I can then use as a reference in the naming part of the macro?

AAA Jan Jan-Mar
AAA Feb Jan-Mar
AAA Mar Jan-Mar
BBB Apr Apr-May
BBB May Apr-May
CCC Feb Feb-May
CCC Mar Feb-May
CCC Apr Feb-May
CCC May Feb-May

 

[PMARI]

Dear Sektor,

I also need same kind of Code. So tested this , New works books are well created, but with empty cells. High lighted the line asking for debug.

Please see this and if possible, please help.

Regards, PM

Sub SplitFile()

    Dim i As Long
    Dim arrFruits As Variant, arrBooks() As Workbook
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Sheet1.AutoFilterMode = False
    
    arrFruits = Array("Apple", "Orange", "Grapes")
    ReDim arrBooks(0 To UBound(arrFruits))
    
    ' Create workbooks.
    For i = 0 To UBound(arrFruits)
        Set arrBooks(i) = Workbooks.Add
    Next
    
    ' Retrieve data by autofilter.
    With Sheet1
        For i = 0 To UBound(arrFruits)
           [COLOR="red"] .Range("A1:A3").AutoFilter Field:=1, Criteria1:=arrFruits(i)[/COLOR]
            .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
            Workbooks(arrBooks(i).Name).Sheets(1).Range("A1").PasteSpecial
        Next
    End With

    ' Save all workbooks.
    For i = 0 To UBound(arrBooks)
        Workbooks(arrBooks(i).Name).SaveAs Filename:=ThisWorkbook.Path & "\" & arrFruits(i) & ".xlsx"
    Next

    ' Clean-up.
    Application.ScreenUpdating = False
    Sheet1.AutoFilterMode = False
    Application.DisplayAlerts = True

End Sub

 

[Sektor]

Sub SplitFile()

    Dim i As Long, j As Long, f As Long, rng As Range
    Dim arrFruits As Variant, arrBooks() As Workbook
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Sheet1.AutoFilterMode = False
    
    arrFruits = Array("Apple", "Orange", "Grapes")
    ReDim arrBooks(0 To UBound(arrFruits))
    
    ' Create workbooks.
    For i = 0 To UBound(arrFruits)
        Set arrBooks(i) = Workbooks.Add
    Next
    
    ' Retrieve data by autofilter.
    With Sheet1
        For i = 0 To UBound(arrFruits)
            With .Range("A1").CurrentRegion
                j = .Rows.Count - 1
                f = .Columns.Count
            End With
            .Range("A1:A3").AutoFilter Field:=1, Criteria1:=arrFruits(i)
            Set rng = .Range(.Range("A1"), .Cells(j, f).SpecialCells(xlCellTypeVisible))
            If Not rng Is Nothing Then
                Workbooks(arrBooks(i).Name).Sheets(1).Range("A1").PasteSpecial
            End If
        Next
    End With

    ' Save all workbooks.
    For i = 0 To UBound(arrBooks)
        Workbooks(arrBooks(i).Name).SaveAs filename:=ThisWorkbook.Path & "\" & arrFruits(i) & ".xlsx"
    Next

    ' Clean-up.
    Application.ScreenUpdating = False
    Sheet1.AutoFilterMode = False
    Application.DisplayAlerts = True

End Sub

 

[Atul_123]

dear sir

i hve bellow mention problem

Sub SPLIT()
' SPLIT Macro
' Keyboard Shortcut: Ctrl+Shift+W
    ChDir "D:\MARGIN REPORT"
    Workbooks.Open Filename:="D:\MARGIN REPORT\MARGIN REPORT.XLS"
    Application.Goto Reference:="SPLIT.xls!SPLIT"
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Sheet1.AutoFilterMode = False
    
    arrBranch_code = Array("6DK", "6VK", "AHMEDNGR", "AKBAR", "AKSHAT", "ALEPHATA", "ALL")
    reSPLIT arrBooks(0 To UBound(arrBranch_code))
    
    ' Create workbooks.
    For i = 0 To UBound(arrBranch_code)
        Set arrBooks(i) = Workbooks.Add
    Next
    
    ' Retrieve data by autofilter.
    With Sheet1
        For i = 0 To UBound(arrbracnh_code)
            .Range("A1:A3").AutoFilter Field:=1, Criteria1:=arrBranch_code(i)
            .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
            Workbooks(arrBooks(i).Name).Sheets(1).Range("A1").PasteSpecial
        Next
    End With
    ' Save all workbooks.
    For i = 0 To UBound(arrBooks)
        Workbooks(arrBooks(i).Name).SaveAs Filename:=ThisWorkbook.Path & "\" & arrBranch_code(i) & ".xlsx"
    Next
    ' Clean-up.
    Application.ScreenUpdating = False
    Sheet1.AutoFilterMode = False
    Application.DisplayAlerts = True

    ActiveWindow.Close
    ActiveWindow.Close
End Sub