String operation VBA Excel - string

Question

I am struggling with the following problem.
I want to do following operations on Input Col A and produce output in col B:
1.Remove Duplicates if any ( It was easy and completed )
2.Remove Leading and/or Trailing spaces from the string (It was easy as well and it's done )
3.COLLECT THE DIFFERENT TRANSLATIONS OF A WORD IN SAME CELL - AVOID DUPLICATES ( It's hard and I don't know how to proceed with this problem )
To understand this point have a look at input/output example.
Input:
A
 absolution
 absolution
 absolutism
 absolutism, absolute rule
  absolutist   
  absolutist   
 absorb
 absorb
 absorb, bind
 absorb, take up
 absorb
 absorb, imbibe, take up
 absorb, sorb
 absorb, take up
 absorb, take up
 absorb, imbibe
 absorb
 absorb
 absorber
 absorber
 absorber
Output:
col B
absolution
absolutism, absolute rule
absolutist
absorb, bind, imbibe, take up, sorb
absorber
I tried with the following code but I am stuck on the third point/step
Option Explicit
Sub StrMac()
Dim wk As Worksheet
Dim i, j, l, m As Long
Dim strc, strd, fstrc, fstrd As String
Dim FinalRowC, FinalRowD As Long
Set wk = Sheet1
wk.Columns(1).Copy Destination:=wk.Columns(3)
wk.Columns(2).Copy Destination:=wk.Columns(4)
wk.Range("$C:$C").RemoveDuplicates Columns:=1, Header:=xlNo
wk.Range("$D:$D").RemoveDuplicates Columns:=1, Header:=xlNo
FinalRowC = wk.Range("C1048576").End(xlUp).Row
FinalRowD = wk.Range("D1048576").End(xlUp).Row
If FinalRowC >= FinalRowD Then
j = FinalRowC
Else
j = FinalRowD
End If
For i = 1 To j
If wk.Range("C" & i).Text <> "" Then
strc = wk.Range("C" & i).Text
strc = Replace(strc, Chr(160), "")
strc = Application.WorksheetFunction.Trim(strc)
wk.Range("C" & i).Value = strc
Else: End If
If wk.Range("D" & i).Text <> "" Then
strd = wk.Range("D" & i).Text
strd = Replace(strd, Chr(160), "")
strd = Application.WorksheetFunction.Trim(strd)
wk.Range("D" & i).Value = strd
Else: End If
Next i
Dim Cet, Det, Fet, Met, s As Variant
Dim newstr
Dim pos, cos As Long
s = 1
For i = 1 To j
If wk.Range("D" & i).Text <> "" Then
l = 2
strd = wk.Range("D" & i).Text
newstr = strd
For m = i + 1 To j
pos = 1100
cos = 2300
fstrd = wk.Range("D" & m).Text
cos = InStr(1, fstrd, ",")
pos = InStr(1, fstrd, strd, vbTextCompare)
If wk.Range("D" & m).Text <> "" And Len(fstrd) > Len(strd) And m <= j And cos <> 2300 And pos = 1 Then
l = 5
newstr = newstr & "," & fstrd
wk.Range("D" & m) = ""
Else: End If
Next m
wk.Range("E" & s) = newstr
s = s + 1
Else: End If
Next i
End Sub

Answer 1

Assuming your input is column A and you want the output in column B (as stated in your question), the following should work for you:
Sub tgr()
Dim ws As Worksheet
Dim rData As Range
Dim aData As Variant
Dim vData As Variant
Dim vWord As Variant
Dim aResults() As String
Dim sUnq As String
Dim i As Long
Set ws = ActiveWorkbook.Sheets("Sheet1")
Set rData = ws.Range("A1", ws.Cells(Rows.Count, "A").End(xlUp))
If rData.Cells.Count = 1 Then
'Only 1 cell in the range, check if it's no blank and output it's text
If Len(Trim(rData.Text)) > 0 Then ws.Range("B1").Value = WorksheetFunction.Trim(rData.Text)
Else
'Remove any extra spaces and sort the data
With rData
.Value = Evaluate("index(trim(" & .Address(external:=True) & "),)")
.Sort .Cells, xlAscending, Header:=xlNo
End With
aData = rData.Value 'Load all values in range to array
ReDim aResults(1 To rData.Cells.Count, 1 To 1) 'Ready the results array
For Each vData In aData
'Get only unique words
If InStr(1, vData, ",", vbTextCompare) = 0 Then
If InStr(1, "," & sUnq & ",", "," & vData, vbTextCompare) = 0 Then
sUnq = sUnq & "," & vData
If i > 0 Then aResults(i, 1) = Replace(aResults(i, 1), ",", ", ")
i = i + 1
aResults(i, 1) = vData
End If
Else
'Add unique different translations for the word
For Each vWord In Split(vData, ",")
If InStr(1, "," & aResults(i, 1) & ",", "," & Trim(vWord) & ",", vbTextCompare) = 0 Then
aResults(i, 1) = aResults(i, 1) & "," & Trim(vWord)
End If
Next vWord
End If
Next vData
End If
'Output results
If i > 0 Then ws.Range("B1").Resize(i).Value = aResults
End Sub