T4478_Split To Worksheets By List In Column

https://excel-egy.com/forum/t4478
---------------------------------

Sub Split_To_Worksheets_By_List_In_Column()
    Dim a, i As Long, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    With Sheets("Sheet3").Cells(1).CurrentRegion
        a = .Columns(2).Value
        For i = 2 To UBound(a, 1)
            If Not dic.Exists(a(i, 1)) Then
                dic(a(i, 1)) = Empty
                If Not Evaluate("ISREF('" & a(i, 1) & "'!A1)") Then
                    Sheets.Add(, Sheets(Sheets.Count)).Name = a(i, 1)
                End If
                Sheets(a(i, 1)).Cells.Clear
                .AutoFilter 2, a(i, 1)
                .Copy Sheets(a(i, 1)).Cells(1)
                .AutoFilter
            End If
        Next i
    End With
End Sub