Function STexts2(Textrange As Range)
Dim i As Integer, x As Object, rng As Range
Set x = CreateObject("scripting.dictionary")
For Each rng In Textrange
If Len(rng) > 0 And Not x.exists(CStr(rng)) _
Then x.Add CStr(rng), rng: i = i + 1
Next
STexts2 = Join(x.items, ", ")
End Function

Then .Item(UCase(Spart)) = i

Function STexts2(Textrange As Range)
    Dim Delimeter As String, i As Long, Aaa, Spart
    Delimeter = ","
    With CreateObject("scripting.dictionary")
        For i = 1 To Textrange.Cells.Count
            If Len(Textrange(i)) > 0 Then
                Aaa = Split(Textrange(i).Value, Delimeter)
                If IsArray(Aaa) Then
                    For Each Spart In Aaa
                        If Len(Trim(Spart)) Then .Item(UCase(Replace_symbols(Spart))) = i
                    Next
                Else
                    If Len(Trim(Spart)) Then .Item(UCase(Replace_symbols(Aaa))) = i
                End If
            End If
        Next i
        If .Count > 1 Then STexts2 = Join(.keys, Delimeter & " ") Else STexts2 = Join(.keys, "")
    End With
End Function

Private Function Replace_symbols(ByVal sStr As String) As String
    Dim i As Byte
    Dim St As String
    St = " !#$%&'()*+,-./:;<=>?[\]_`{|}~"    ' В этой строке лишние символы.
    For i = 1 To Len(St)
        sStr = Replace(sStr, Mid(St, i, 1), "")
    Next
    Replace_symbols = sStr
End Function