GBKEE

¦^´_ 1# tony0318
¯Â°Ñ¦Ò ¥t¤@ºØ¤è¦¡ ¨Ï¥Î °}¦C
Sub Ex()
    Dim Ar(), M$, A As Range, i%
    ReDim Ar(0)
    With Sheet1
       Set Ar(0) = .Range("A1").Resize(1, 12)
        M = .Range("C1")
        For Each A In .Range(.[A2], .[A65536].End(xlUp))
            If UBound(Filter(Split(M, ","), A(1, 3), True)) > -1 Then
                i = Application.Match(A(1, 3), Split(M, ","), 0)
                Set Ar(i - 1) = Union(Ar(i - 1), A.Resize(1, 12))
            Else
                M = M & "," & A(1, 3)
                ReDim Preserve Ar(UBound(Ar) + 1)
                Set Ar(UBound(Ar)) = Union(Ar(0), A.Resize(1, 12))
            End If
        Next
    End With
    On Error GoTo NewSheet
    For i = 1 To UBound(Split(M, ","))
        With Sheets(Split(M, ",")(i))
            .Cells.Clear
            Ar(i).Copy .Range("A1")
        End With
    Next
    Sheet1.Activate
    Exit Sub
NewSheet:
    With Sheets.Add(after:=Sheets(Sheets.Count))
        .Name = Split(M, ",")(i)
    End With
    Resume
End Sub