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

 

[JillC]

Your code it excellent and the only one I've been able to get to partially work. However, though it returns new workbooks with the correct names, they're either blank or only have the first half of the first row in it. Most likely, I made the changes I need incorrectly. If you have a moment, would you please tell me what I did wrong? I triple checked everything but I can't figure it out. The changes I made are in red.

Pertinent Information:
The data is in cells A2:N236; column titles are in row 2.
Column D contains data for sorting the info into the new workbooks; D2 is titles "Regional"

Sub SplitFile()


    Dim i As Long
    Dim arrRegional As Variant, arrBooks() As Workbook
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Sheet1.AutoFilterMode = False
    
    [COLOR=#ff0000]arrRegional[/COLOR] = Array([COLOR=#ff0000]"Jones, Ralph", "Nesbit, Jessica", "Kinsley, Joe", "Dodger, David"[/COLOR])
    ReDim arrBooks(0 To UBound(arrRegional))
    
    ' Create workbooks.
    For i = 0 To UBound([COLOR=#ff0000]arrRegional[/COLOR])
        Set arrBooks(i) = Workbooks.Add
    Next
    
    ' Retrieve data by autofilter.
    With Sheet1
        For i = 0 To UBound([COLOR=#ff0000]arrRegional[/COLOR])
            .Range([COLOR=#ff0000]"A2:N263"[/COLOR]).AutoFilter Field:=[COLOR=#ff0000]4[/COLOR], Criteria1:=[COLOR=#ff0000]arrRegional[/COLOR](i)
            .Range("[COLOR=#ff0000]A2[/COLOR]").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
            Workbooks(arrBooks(i).Name).Sheets(1).Range("[COLOR=#ff0000]A2[/COLOR]").PasteSpecial
        Next
    End With


    ' Save all workbooks.
    For i = 0 To UBound(arrBooks)
        Workbooks(arrBooks(i).Name).SaveAs Filename:=ThisWorkbook.Path & "\" & [COLOR=#ff0000]arrRegional[/COLOR](i) & ".xlsx"
    Next


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


End Sub

 

[Pricing_analyst]

'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.

I tried your macro which seems to be very good but I have an error on
'Loop through list one value at a time
For Itm = 1 To UBound(MyArr)
ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)

and I don't understand what is wrong. could you help me on this?

 

[jbeaucaire]

No, not blindly. When the error occurs, what is the current value of MyArr(Itm) ?

 

[breathless]

Hi,
This is an excellent code and it works perfectly. However, the columns have all the same width and I'd like to have them set automatically to the best width (and no wrapped text). No matter what I've tried (and it's limited - my macro skills are limied) it doesn't work. Any ideas?
Also, the cherry on top would be to have also the printing settings copied (fit all columns on one page). Any suggestions?
KR
breathless

 

[jbeaucaire]

Autofit columns:

Cells.Columns.AutoFit

Reset print setup to 1 page wide:

 With ActiveSheet.PageSetup
    .Zoom = False
    .FitToPagesWide = 1
    .FitToPagesTall = False 
End With

 

[breathless]

Autofit columns:

Cells.Columns.AutoFit

Thanks. I've got this already in the code but it does not seem to work - all columns have the same width.

 

[jbeaucaire]

Post your fully tweaked version of the code you're using, let's have a look.

 

[breathless]

Option Explicit

Sub ParseItems()
'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

'Sheet with data in it
   Set ws = Sheets("Salary")

'Path to save files into, remember the final \
    SvPath = "C:\Users\GCU\Desktop\Test splitt\"

'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:AU1"
   
'Choose column to evaluate from, column A = 1, B = 2, etc.
   vCol = Application.InputBox("What column to split data by? " & vbLf _
        & vbLf & "(A=1, B=2, C=3, etc)", "Which column?", 1, Type:=1)
   If vCol = 0 Then Exit Sub

'Spot bottom row of data
   LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

'Speed up macro execution
   Application.ScreenUpdating = False

'Get a temporary list of unique values from key column
    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.EntireColumn.AutoFit
        MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 1
        
        
        'ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, " MM-DD-YY"), xlNormal
        ActiveWorkbook.SaveAs SvPath & ActiveSheet.Range("A2").Value & ".xlsx", 51    'use for Excel 2007+
        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

 

[jbeaucaire]

I'm stumped, it seems correct to my eye. I even tested it on a few standalone workbooks, whatever sheet is onscreen gets autofitted. Weird.

 

[breathless]

Found it...!! the download from our system I am using has the format "wrap text" preset... so there we go... no use in searching the code! once that is set right it works. Sweet!
Printer settings work fine.
Thank you! Much appreciated!