need to remove duplicate words in a cell

have a column of cells like this

ORIGINAL
world, industry, generation, industry
leader, leader, Covered, supplies
transformation, margin

NEED THIS TO BE
world, industry, generation
leader, Covered,
transformation, margin

VBA

Last Comment

finnstone

8/22/2022 - Mon

Pawan Kumar

12/2/2017

SELECT that column -> go to DATA tab -> CLICK remove duplicates--> You are done.

finnstone

12/2/2017

ASKER

that is not correct

finnstone

12/2/2017

ASKER

dupes only should be removed from within the same cell

All of life is about relationships, and EE has made a viirtual community a real community. It lifts everyone's boat

William Peck

Pawan Kumar

12/2/2017

Is it a one time activity ?

ASKER CERTIFIED SOLUTION

Bill Prew

12/2/2017

THIS SOLUTION ONLY AVAILABLE TO MEMBERS.

View this solution by signing up for a free trial.

Members can start a 7-Day free trial and enjoy unlimited access to the platform.

See Pricing Options

Start Free Trial

GET A PERSONALIZED SOLUTION

Ask your own question & get feedback from real experts

Find out why thousands trust the EE community with their toughest problems.

Martin Liss

12/2/2017

Ignore this if Bill's code works for you.

Otherwise add and run this macro. Note lines 8 and 9.

Sub RemoveCellDupes()
Dim lngLastRow As Long
Dim lngRow As Long
Dim colWords As Collection
Dim strWords() As String
Dim lngIndex As Long
Dim lngNextRow As Long
Const DATA_COL = "A" ' Change as needed
Const FIRST_ROW = 1 ' Change as needed

lngLastRow = Range(DATA_COL & "1048576").End(xlUp).Row
lngNextRow = FIRST_ROW

For lngRow = FIRST_ROW To lngLastRow
    Set colWords = New Collection
    strWords = Split(Cells(lngRow, DATA_COL), ",")
    For lngIndex = 0 To UBound(strWords) 
        On Error Resume Next
        colWords.Add Trim(strWords(lngIndex)), Trim(strWords(lngIndex))
    Next
    Cells(lngNextRow, DATA_COL).ClearContents
    For lngIndex = 1 To colWords.Count
        If lngIndex < colWords.Count Then
            Cells(lngNextRow, DATA_COL) = Cells(lngNextRow, DATA_COL) & colWords(lngIndex) & ", "
        Else
            Cells(lngNextRow, DATA_COL) = Cells(lngNextRow, DATA_COL) & colWords(lngIndex)
        End If
    Next
    lngNextRow = lngNextRow + 1
Next
End Sub

Open in new window

Subodh Tiwari (Neeraj)

12/2/2017

Assuming each word in the cell is separated by a comma, you may give this a try...

Function getUniqueWords(ByVal vStr As String) As String
Dim str() As String
Dim dict
Dim i As Long

str = Split(Replace(Replace(vStr, Chr(10), ""), " ", ""), ",")
Set dict = CreateObject("Scripting.Dictionary")
For i = 0 To UBound(str)
    dict.Item(str(i)) = ""
Next i
If dict.Count > 0 Then getUniqueWords = Join(dict.keys, ", ")
End Function