Sub String_Undoubler()

'Author:    Roman Rioran Voronov
'Date:      the 13-th of August, 2014
'Feedback:  voronov_rv@mail.ru

'Purpose:   Realisation of algorithm for excel-world.ru user
'           http://www.excelworld.ru/forum/10-12448-1?lZ4feq#

Dim X As Long 'To roll rows
Dim strX As String 'To deal with cells
Dim A As Long 'To roll through strX
Dim B As Long 'To find amount of strings inside strX
Dim C As Long 'To remember last ", " position in strX
Dim D As Long 'To roll inner circle for arrX
Dim Y As Boolean 'May we join this piece to strX?
Dim arrX() 'To keep different pieces

With ThisWorkbook.Sheets("Data")
Application.ScreenUpdating = False

For X = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
      strX = .Cells(X, 1).Value
      If strX = "" Then Exit For
      B = (Len(strX) - Len(Replace(strX, ", ", ""))) / Len(", ")
      ReDim arrX(1 To B + 1)
      C = InStr(1, strX, ", ", 1)
      arrX(1) = Left(strX, C - 1)

      'Filling arrX with values
      For A = 1 To B
          If A = B Then
              arrX(A + 1) = Right(strX, Len(strX) - (C + 1))
              Exit For
          End If
          arrX(A + 1) = Left(Right(strX, Len(strX) - (C + 1)), InStr(C + 1, strX, ", ", 1) - (C + 2))
          C = InStr(C + 1, strX, ", ", 1)
      Next A
        
      'Reforging strX
      strX = arrX(1)
      For A = 2 To B + 1
          Y = True
          For D = 1 To A - 1
              If arrX(A) = arrX(D) Then
                  Y = False
                  Exit For
              End If
          Next D
          If Y Then
              strX = strX & ", " & arrX(A)
          End If
      Next A
        
      .Cells(X, 1).Value = strX
Next X

Application.ScreenUpdating = True
End With
End Sub