Option Explicit

Sub Разделить()
    Dim arr As Variant
    arr = GetArr(Selection)
    If IsEmpty(arr) Then Exit Sub
    
    PrintArray arr
End Sub

Private Sub PrintArray(arr As Variant)
    Dim rr As Range
    Set rr = ActiveSheet.UsedRange
    Set rr = rr.Rows(rr.Rows.Count + 2)
    Set rr = rr.Resize(UBound(arr, 1), UBound(arr, 2))
    rr.Value = arr
    SortRange rr
    
    Application.Goto rr
End Sub

Private Function GetArr(rr As Range) As Variant
    On Error Resume Next
    Set rr = Intersect(rr, rr.Parent.UsedRange)
    On Error GoTo 0
    If rr Is Nothing Then Exit Function
    
    Dim rArea As Range, arr As Variant, vv As Variant, ww As Variant
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For Each rArea In rr.Areas
        If rArea.Cells.CountLarge = 1 Then
            arr = Array(rArea.Value)
        Else
            arr = rArea.Value
        End If
        For Each vv In arr
            For Each ww In Split(vv, ",")
                dic(Trim(ww)) = Empty
            Next
        Next
    Next
    If dic.Count = 0 Then Exit Function
    arr = dic.Keys()
    GetArr = TwoDimArr(arr)
End Function

Private Function TwoDimArr(arr As Variant) As Variant
    Dim brr As Variant
    ReDim brr(1 To UBound(arr) + 1, 1 To 1)
    Dim ya As Long
    For ya = LBound(arr) To UBound(arr)
        brr(ya + 1, 1) = arr(ya)
    Next
    TwoDimArr = brr
End Function

Private Sub SortRange(rr As Range)
    With rr.Parent.Sort
        .SortFields.Clear
        .SortFields.Add Key:=rr.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange rr
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub