Sub CopyList()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Sheet1.Activate

Dim ListRange As Range
Set ListRange = Range("B3", Range("B3").End(xlDown))

ListRange.Cells(1, 1).Select

Dim i As Long

Do While ActiveCell <> ""
i = WorksheetFunction.CountIf(ListRange, ActiveCell.Value)
Range(ActiveCell, ActiveCell.Offset(i - 1, -1)).Copy
ActiveCell.Offset(i, 0).Select

Sheets.Add after:=Sheets(Worksheets.Count)
ActiveCell.PasteSpecial
On Error Resume Next
ActiveSheet.Name = Cells(1, 2).Value
Selection.EntireColumn.AutoFit

Sheet1.Activate
Loop

Range("A1").Select

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Attached Files

CopyList.xlsm (19.7 KB, 9 views)