Macro to split one file into many based on criteria

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

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

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

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

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