I would like to split one worksheet into many files based on criteria in two columns

[paulfields4]

Here is the code I have thus far. It works fine for basing criteria one column but I need to be based on two. Have multiple consultants but the may have two different types of accounts. These types of accounts would be my sub criteria to the consultant column. I also would need the file to be saved something like SRBD Detail File , then current month and year.

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("Sheet4")
'Path to save files into, remember the final \
SvPath = "H:\"
'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:V1"

'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.Columns.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 & MyArr(Itm) & Format(Date, " MM-DD-YY") & ".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

 

[asifaui]

I have:
Single spread sheet with 10 columns
Last three columns(for instance L,M and N) having conditional formatting i.e. highlights a minimum value among three.
I want(once it is conditionally formatted):
To split into three spread sheets having same headers
Each new sheet should only contain all the rows with respect highlighted values of column L, M and N.

PS: So far I was doing by apply filter on first sheet then copy past. But it is a lengthy process due to huge volume of data.