Split Worksheet to multiple workbooks

'ONE SHEET to WORKBOOKS (1)
Here's a base macro for taking a sheet with data and creating individual wbs from each unique value in a chosen column. The date is added to the workbook names to give a reference as to when the wbs were created.

SHEET to WORKBOOKS(1)

To apply this to your data, I think the solution is to add this formula to the next empty column. Based on your example I'm guessing that is column L. So in L2 you would put this formula to concatenate your thress values into a single value:

=I2 & "_" & J2 & K2 & ".xls"

Now copy that formula down the whole dataset and you're ready to run the macro. Here's an edited version of the macro above:

Option Explicit

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

'Sheet with data in it
   Set ws = Sheets("Original Data")             'EDIT THIS

'Path to save files into, remember the final \
    SvPath = "C:\2010\"                         'EDIT THIS

'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"
   
'Choose column to evaluate from, column A = 1, B = 2, etc.
   vCol = 12                                    'EDIT THIS IF YOU PUT FORMULA IN DIFF COLUMN

'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 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", ws.Cells(LR, vCol - 1)).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), 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

How'd that work for you?

If that takes care of your need, please select Thread Tools from menu above and set this topic to SOLVED.