This demo will be scaled up to perform this operation on data ranges with 100's of rows, so I'm not sure how to make the runtime faster, and avoid selecting different sized ranges using the xlToRight if there was adjacent data. Attached is a view-only xlsm. spreadsheet
Sub Main_Loop()
' This script references the number of unique items in the
' filter then loops the data extraction based on this value.
'
' Keyboard Shortcut: Ctrl+Shift+Z
'
' Nate_Ayers
Application.ScreenUpdating = False
Range("H1").Select
Dim i As Integer 'counter
Dim Loop_var As String
Loop_end = Range("A2").Value2 'Stop loop at end of unique items
For i = 1 To Loop_end
Selection.Copy
Range("A3").Select 'Helper cell location chosen where data wont overwrite the cell
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False 'Paste values only (avoids unique function)
Application.CutCopyMode = False
Selection.Copy
Columns("C:C").AutoFilter
ActiveSheet.Range("C:C").AutoFilter Field:=1, Criteria1:=Range("A3")
'Data block grab:
Range("C2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets.Add After:=ActiveSheet
Range("A2").Select
ActiveSheet.Paste
Range("A2").Select
Application.CutCopyMode = False
Selection.Copy
Worksheets(ActiveSheet.Index).Select 'could have efficiency improvement
Worksheets(ActiveSheet.Index).Name = Selection 'Name the sheet
Range("A1").Select
ActiveSheet.Paste
Selection.Font.Bold = True
Sheets("Demo").Select
Range("A3").Select
Selection.ClearContents
Selection.AutoFilter
Range("H1").Select
ActiveCell.Offset(0, i).Select 'Reference next row to repeat operations
Next i
Application.ScreenUpdating = True
End Sub