separate data with column item

This is a macro published on my blog here. I've simply tweaked the 3 variables:

vCol = 7
Set ws = Sheets("Sheet1")
vTitles = "A1:L1"


Here's the full edited code:

Option Explicit

Sub ParseItems()
'Author:    Jerry Beaucaire
'Date:      11/11/2009
'Summary:   Based on selected column, data is filtered to individual sheets
'           Creates sheets and sorts sheets alphabetically in workbook
'           6/10/2010 - added check to abort if only one value in vCol
'           7/22/2010 - added ability to parse numeric values consistently
'           11/16/2011 - changed way Unique values are collected, no Adv Filter
'           12/23/2013 - option to append incoming data
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long, iCol As Long, NR As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, TitleRow As Long, Append As Boolean

Application.ScreenUpdating = False
'Column to evaluate from, column A = 1, B = 2, etc.
   vCol = 7
 
'Sheet with data in it
   Set ws = Sheets("Sheet1")

'option to append new data below old data
If MsgBox(" If sheet exists already, add new data to the bottom?" & vbLf & _
           "(if no, new data will replace old data)", _
           vbYesNo, "Append new Data?") = vbYes Then Append = True
'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:L1"
    TitleRow = Range(vTitles).Cells(1).Row

'Spot bottom row of data
   LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row
'Get a temporary list of unique values from vCol
    iCol = ws.Columns.Count
    ws.Cells(1, iCol) = "key"
   
    For Itm = TitleRow + 1 To LR
        On Error Resume Next
        If ws.Cells(Itm, vCol) <> "" And Application.WorksheetFunction _
            .Match(ws.Cells(Itm, vCol), ws.Columns(iCol), 0) = 0 Then
               ws.Cells(ws.Rows.Count, iCol).End(xlUp).Offset(1) = ws.Cells(Itm, vCol)
        End If
    Next Itm
'Sort the temporary list
    ws.Columns(iCol).Sort Key1:=ws.Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'Put list into an array for looping
    MyArr = Application.WorksheetFunction.Transpose _
        (ws.Columns(iCol).SpecialCells(xlCellTypeConstants))
'clear temporary list
    ws.Columns(iCol).Clear
'Turn on the autofilter
    ws.Range(vTitles).AutoFilter
'Loop through list one value at a time
'The array includes the title cell, so we start at the second value in the array
    For Itm = 2 To UBound(MyArr)
        ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=CStr(MyArr(Itm))
   
        If Not Evaluate("=ISREF('" & CStr(MyArr(Itm)) & "'!A1)") Then   'create sheet if needed
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CStr(MyArr(Itm))
            NR = 1
        Else                                                            'if it exists already
            Sheets(CStr(MyArr(Itm))).Move After:=Sheets(Sheets.Count)   'ordering the sheets
            If Append Then                                              'find next empty row
                NR = Sheets(CStr(MyArr(Itm))).Cells(Rows.Count, vCol).End(xlUp).Row + 1
            Else
                Sheets(CStr(MyArr(Itm))).Cells.Clear                    'clear data if not appending
                NR = 1
            End If
        End If
   
        If NR = 1 Then                                                  'copy titles and data
            ws.Range("A" & TitleRow & ":A" & LR).EntireRow.Copy Sheets(CStr(MyArr(Itm))).Range("A" & NR)
        Else                                                            'copy data only
            ws.Range("A" & TitleRow + 1 & ":A" & LR).EntireRow.Copy Sheets(CStr(MyArr(Itm))).Range("A" & NR)
        End If
       
        ws.Range(vTitles).AutoFilter Field:=vCol                        'reset the autofilter
        If Append And NR > 1 Then NR = NR - 1
        MyCount = MyCount + Sheets(CStr(MyArr(Itm))).Cells(Rows.Count, vCol).End(xlUp).Row - NR
        Sheets(CStr(MyArr(Itm))).Columns.AutoFit
    Next Itm
   
'Cleanup
    ws.Activate
    ws.AutoFilterMode = False
    MsgBox "Rows with data: " & (LR - TitleRow) & vbLf & "Rows copied to other sheets: " _
                & MyCount & vbLf & "Hope they match!!"
    Application.ScreenUpdating = True
End Sub

I've installed into your workbook and added a button.