Option Explicit
Sub Extract()
Dim arr(), x, temp, itxt
Dim cl As Range
Dim i&

'On Error resume next
Set cl = Application.InputBox("Укажите ячейку вставки:", "Выбрать ОДНУ ячейку", , Type:=8)
temp = Selection.Value2: itxt = Join(temp, ", ")
temp = Split(itxt, ", "): arr = GetUniqArrFromArr(temp)

cl.Resize(UBound(arr) + 1).Value2 = WorksheetFunction.Transpose(arr)

'fin:
End Sub
'================================================================================================================
Public Function GetUniqArrFromArr(WF_arr As Variant) As Variant
Dim x, iTemp

    With CreateObject("Scripting.Dictionary")
        For Each x In WF_arr
            If Len(x) > 0 Then iTemp = .Item(x)
        Next x
    GetUniqArrFromArr = .Keys
    End With
End Function

Option Explicit
Sub Extract()
Dim arr(), x(), temp
Dim cl As Range
Dim i&
Dim itxt$

Set cl = Application.InputBox("Укажите ячейку вставки:", "Выбрать ОДНУ ячейку", , Type:=8)
itxt = PRDX_Merge_Prist(Selection, ", ")
temp = Split(itxt, ", "): arr() = GetUniqArrFromArr(temp)
cl.Resize(UBound(arr) + 1).Value2 = WorksheetFunction.Transpose(arr)

End Sub
'================================================================================================================
Public Function GetUniqArrFromArr(WF_arr As Variant) As Variant
Dim x, iTemp

    With CreateObject("Scripting.Dictionary")
        For Each x In WF_arr
            If Len(x) > 0 Then iTemp = .Item(x)
        Next x
    GetUniqArrFromArr = .Keys
    End With
End Function
'================================================================================================================
'Функция по мотивам СцепитьЕсли от Дмитрия Щербакова
'================================================================================================================
Public Function PRDX_Merge_Prist(WF_rng As Range, Optional WF_delim As String = "—", Optional WF_uniq As Boolean = False, Optional WF_NoDash As Boolean = True) As String
Dim WF_area As Range
Dim WF_arr
Dim WF_lr&, WF_lc&
Dim WF_temp$
    
On Error GoTo er
    For Each WF_area In WF_rng.Areas
        WF_arr = WF_area.Value
        If Not IsArray(WF_arr) Then
            ReDim WF_arr(1 To 1, 1 To 1)
            WF_arr(1, 1) = WF_area.Value
        End If
      
        For WF_lc = 1 To UBound(WF_arr, 2)
            For WF_lr = 1 To UBound(WF_arr, 1)
                If (Len(WF_arr(WF_lr, WF_lc)) = 0) Or (WF_NoDash = True And WF_arr(WF_lr, WF_lc) = Chr(151)) Then GoTo nx:
            WF_temp = WF_temp & WF_delim & WF_arr(WF_lr, WF_lc)
nx:
            Next WF_lr
        Next WF_lc
    Next WF_area
    If Len(WF_temp) Then
        WF_temp = Mid(WF_temp, Len(WF_delim) + 1)
    End If
       
    If WF_uniq = True Then
        Dim oDict As Object, sTmpStr
        Set oDict = CreateObject("Scripting.Dictionary")
        sTmpStr = Split(WF_temp, WF_delim)
        On Error Resume Next
        For WF_lr = LBound(sTmpStr) To UBound(sTmpStr)
            oDict.Add sTmpStr(WF_lr), sTmpStr(WF_lr)
        Next WF_lr
        WF_temp = ""
        sTmpStr = oDict.Keys
        For WF_lr = LBound(sTmpStr) To UBound(sTmpStr)
            WF_temp = WF_temp & IIf(WF_temp <> "", WF_delim, "") & sTmpStr(WF_lr)
        Next WF_lr
    End If
PRDX_Merge_Prist = WF_temp: GoTo fin

er:
PRDX_Merge_Prist = ""

fin:
On Error GoTo 0
End Function