Here is my original macro updated to make it more "editable". It is friendlier to use than the one posted above. So use this instead as a basis.
Sub ParseItems()
'JBeaucaire (11/11/2009)
'Based on selected column, data is filtered to individual sheets
'Creates sheets and sorts alphabetically in workbook
Dim LR As Long, i As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String
Application.ScreenUpdating = False
'Column to evaluate from, column A = 1, B = 2, etc.
vCol = 1
'Sheet with data in it
Set ws = Sheets("Data")
'Range where titles are across top of data, as string
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 i = 1 To UBound(MyArr)
ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(i)
If Not Evaluate("=ISREF('" & MyArr(i) & "'!A1)") Then 'create sheet if needed
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = MyArr(i)
Else 'clear sheet if it exists
Sheets(MyArr(i)).Move After:=Sheets(Sheets.Count)
Sheets(MyArr(i)).Cells.Clear
End If
ws.Range("A1:A" & LR).EntireRow.Copy Sheets(MyArr(i)).Range("A1")
ws.Range(vTitles).AutoFilter Field:=vCol
MyCount = MyCount + Sheets(MyArr(i)).Range("A" & Rows.Count).End(xlUp).Row - 1
Sheets(MyArr(i)).Columns.AutoFit
Next i
'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
===========
Sorry I missed your message above. Here is a tweaked version that allows you to use a second sheet. Put the names to use in the second sheet from A2 downward, and call that sheet "Names".
Option Explicit
Sub ParseItems()
'JBeaucaire (11/11/2009)
'Based on selected column, data is filtered to individual sheets
'Creates sheets and sorts alphabetically in workbook
Dim LR As Long, i As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, wsNames As Worksheet, MyArr As Variant, vTitles As String
Application.ScreenUpdating = False
'Column to evaluate from, column A = 1, B = 2, C = 3 etc.
vCol = 1
'Sheet with data in it and sheet with list of names in column A
Set ws = Sheets("Data")
Set wsNames = Sheets("Names")
'Range where titles are across top of data, as string
vTitles = "A1:Z1"
'Spot bottom row of data
LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row
'Get the list of values from another sheet
MyArr = Application.WorksheetFunction.Transpose(wsNames.Range("A2:A" & Rows.Count).SpecialCells(xlCellTypeConstants))
'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 i = 1 To UBound(MyArr)
ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(i)
If Cells(Rows.Count, vCol).End(xlUp).Row > Range(vTitles).Row Then
If Not Evaluate("=ISREF('" & MyArr(i) & "'!A1)") Then 'create sheet if needed
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = MyArr(i)
Else 'clear sheet if it exists
Sheets(MyArr(i)).Move After:=Sheets(Sheets.Count)
Sheets(MyArr(i)).Cells.Clear
End If
ws.Range("A1:A" & LR).EntireRow.Copy Sheets(MyArr(i)).Range("A1")
MyCount = MyCount + Sheets(MyArr(i)).Range("A" & Rows.Count).End(xlUp).Row - 1
End If
ws.Range(vTitles).AutoFilter Field:=vCol
Sheets(MyArr(i)).Columns.AutoFit
Next i
'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
Does this work for you?
Bookmarks