Kubi

¦^´_ 1# greetingsfromtw
½Ð´ú¸Õ
Sub newtest()
    Dim Arr, Brr(), myD As Object
    Set myD = CreateObject("Scripting.Dictionary")
    Arr = Range("a2:c" & Cells(Rows.Count, "a").End(3).Row).Value
    For i = 1 To UBound(Arr)
        For j = 0 To UBound(Split(Arr(i, 2), Chr(10)))
            If Split(Arr(i, 2), Chr(10))(j) <> "" Then myD(Split(Arr(i, 2), Chr(10))(j)) = ""
        Next j
        For Each C In myD
            n = n + 1
            ReDim Preserve Brr(1 To 2, 1 To n)
            Brr(1, n) = Arr(i, 1)
            Brr(2, n) = C
        Next C
        myD.RemoveAll
    Next i
    [E2:F65536].ClearContents
    [E2].Resize(n, 2) = Application.Transpose(Brr)
End Sub