Delete repeated words in every cells in a Range

[mmtoure]

Hello!
I have thousands of cells with repeated terms, and would like to delete the repeated/duplicate words in the cells without deleting the entire rows.

I found the following VBA code (below) on this forum that comes close to achieving this end but with some limitations that I need help with.
Here is an example of a cell content: Measles, Measles, Measles, Measles, Measles, Measles, Measles, Dengue, Dengue, Dengue, Dengue, Dengue, Dengue, Dengue

Running the code gives the following: Measles, , , , , , , Dengue, , , , , ,

But ideally, I would want to just have Measles, Dengue

Any help would be much appreciated. Thanks

Sub RemoveDupilcateWords()

    Dim Cell        As Range
    Dim Dict        As Object
    Dim FirstCell   As Range
    Dim Key         As String
    Dim LastCell    As Range
    Dim Matches     As Object
    Dim NewText     As String
    Dim RegExp      As Object
    Dim Rng         As Range
    Dim Text        As String
    Dim txtArray    As Variant
    Dim i As Long
    Dim j As Long
        Set FirstCell = Range("F2")
        Set LastCell = Cells(Rows.Count, FirstCell.Column).End(xlUp)
        Set Rng = Range(FirstCell, LastCell)
        
        If LastCell.Row < FirstCell.Row Then Exit Sub
        
            Set Dict = CreateObject("Scripting.Dictionary")
            
            Set RegExp = CreateObject("VBScript.RegExp")
            RegExp.Global = True
            RegExp.IgnoreCase = True
            RegExp.Pattern = "([^\,\;\.]+)"
            
            Application.ScreenUpdating = False
            
            For Each Cell In Rng
                Text = Cell
                Set Matches = RegExp.Execute(Text)
                If Matches.Count > 0 Then
                    For i = 0 To Matches.Count - 1
                        txtArray = Split(Matches(i), " ")
                            For j = 0 To UBound(txtArray)
                                Key = Trim(txtArray(j))
                                If Key <> "" Then
                                    If Not Dict.Exists(Key) Then
                                        Dict.Add Key, 1
                                    Else
                                        txtArray(j) = ""
                                    End If
                                End If
                            Next j
                        NewText = NewText & Join(txtArray, " ") & Mid(Text, Matches(i).FirstIndex + Matches(i).Length + 1, 1)
                    Next i
                    Cell = NewText
                    NewText = ""
                    Dict.RemoveAll
                End If
            Next Cell
            
            Application.ScreenUpdating = True
            
End Sub

[akhileshgs]

Please use 'wrap' option while inserting any code

[mmtoure]

Sorry about that. Here is the code wrapped.

	

		

			

			
				Sub RemoveDupilcateWords()

Dim Cell As Range
Dim Dict As Object
Dim FirstCell As Range
Dim Key As String
Dim LastCell As Range
Dim Matches As Object
Dim NewText As String
Dim RegExp As Object
Dim Rng As Range
Dim Text As String
Dim txtArray As Variant
Dim i As Long
Dim j As Long
Set FirstCell = Range("F2")
Set LastCell = Cells(Rows.Count, FirstCell.Column).End(xlUp)
Set Rng = Range(FirstCell, LastCell)

If LastCell.Row < FirstCell.Row Then Exit Sub

Set Dict = CreateObject("Scripting.Dictionary")

Set RegExp = CreateObject("VBScript.RegExp")
RegExp.Global = True
RegExp.IgnoreCase = True
RegExp.Pattern = "([^\,\;\.]+)"

Application.ScreenUpdating = False

For Each Cell In Rng
Text = Cell
Set Matches = RegExp.Execute(Text)
If Matches.Count > 0 Then
For i = 0 To Matches.Count - 1
txtArray = Split(Matches(i), " ")
For j = 0 To UBound(txtArray)
Key = Trim(txtArray(j))
If Key <> "" Then
If Not Dict.Exists(Key) Then
Dict.Add Key, 1
Else
txtArray(j) = ""
End If
End If
Next j
NewText = NewText & Join(txtArray, " ") & Mid(Text, Matches(i).FirstIndex + Matches(i).Length + 1, 1)
Next i
Cell = NewText
NewText = ""
Dict.RemoveAll
End If
Next Cell

Application.ScreenUpdating = True

End Sub
			
		
	

[JOHN H. DAVIS]

Maybe:

Sub mmtoure()

Dim Cell As Range
Dim Dict As Object
Dim FirstCell As Range
Dim Key As String
Dim LastCell As Range
Dim Matches As Object
Dim NewText As String
Dim RegExp As Object
Dim Rng As Range
Dim Text As String
Dim txtArray As Variant
Dim i As Long
Dim j As Long
Set FirstCell = Range("F2")
Set LastCell = Cells(Rows.Count, FirstCell.Column).End(xlUp)
Set Rng = Range(FirstCell, LastCell)

If LastCell.Row < FirstCell.Row Then Exit Sub

Set Dict = CreateObject("Scripting.Dictionary")

Set RegExp = CreateObject("VBScript.RegExp")
RegExp.Global = True
RegExp.IgnoreCase = True
RegExp.Pattern = "([^\,\;\.]+)"

Application.ScreenUpdating = False

For Each Cell In Rng
Text = Cell
Set Matches = RegExp.Execute(Text)
If Matches.Count > 0 Then
For i = 0 To Matches.Count - 1
txtArray = Split(Matches(i), " ")
For j = 0 To UBound(txtArray)
Key = Trim(txtArray(j))
If Key <> "" Then
If Not Dict.Exists(Key) Then
Dict.Add Key, 1
Else
txtArray(j) = ""
End If
End If
Next j
NewText = NewText & Join(txtArray, " ") & Mid(Text, Matches(i).FirstIndex + Matches(i).Length + 1, 1)
Next i
Cell = NewText
NewText = ""
Dict.RemoveAll
End If
Next Cell
With Range("F2:F" & ActiveSheet.UsedRange.Rows.Count).Select
    Cells.Replace ",", "", xlPart
    Cells.Replace " , ", "", xlPart
    Cells.Replace "  ", "", xlPart
    Cells.Replace " ", ", ", xlPart
End With
Application.ScreenUpdating = True

End Sub

[abousetta]

Hello and welcome to the forum,

Please add code tags by highlighting your code and pressing on the pound sign (#) or adding [Code] before your code and [/ Code] after your code (but remove the space between the forward slash and the word Code.

Once you comply, I can post the updated code.

Thanks.

abousetta

[mmtoure]

Hi abousetta,
I just made the edits. Hope that works. Thanks.

[abousetta]

Don't forget to do this for post #1 also:

Here is the updated code. You don't need to use RegScript, only the scripting dictionary:

Option Explicit

Sub RemoveDupilcateWords()
  Dim j As Long, Cell As Range, Rng As Range, arr, Dict As Object
    Set Rng = Range("F2:F" & Range("F" & Rows.Count).End(xlUp).Row)
    Set Dict = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
      For Each Cell In Rng
        With Dict
          arr = Split(Cell.Value, ", ")
          .RemoveAll
          For j = LBound(arr) To UBound(arr)
            .Item(Trim(arr(j))) = 0
          Next
          Cell.Value = Join(.keys, ", ")
        End With
      Next
    Set Dict = Nothing
End Sub

Hope this helps.

abousetta

[mmtoure]

Wow, thanks a lot, abousetta!
It worked like magic.

[mmtoure]

Wow, thanks a lot, abousetta!
It worked like magic.

[abousetta]

Thanks for marking the thread as solved. Good luck.

[abousetta]

Yes, scripting does wonders. I'll be honest I don't know RegEx but you could probably accomplish the same thing there also.

[mmtoure]

Thanks, John for your help as well.

[JOHN H. DAVIS]

Welcome. Glad you got a solution.