CODEWITHSUNDEEP
excelvba
Shiva
Shiva

Reputation: 430

Find duplicate words with in a cell and paste to next column

I am new to excel VBA. I have around 20k rows filled with descriptions in column A. The words are delimited with spaces. I need to find repeated words (not letters) available in column A and paste them in column B as depicted below.

+---------------------------------------------+-----------+
|                   A                         |     B     |
+---------------------------------------------+-----------+
| STEEL ROD BALL BEARING STEEL ROD            | STEEL ROD |
+---------------------------------------------+-----------+
| I LIKE MICROSOFT EXCEL AND MICROSOFT ACCESS | MICROSOFT |
+---------------------------------------------+-----------+

I searched over the internet and I could not find as required. This link helped me to remove duplicates. I don't want to remove them but copy to the next column.

Upvotes: 0

Views: 2231

Answers (2)

Netloh
Netloh

Reputation: 4378

You could use a code like:

Sub FindDuplicates()
    Dim i As Long
    Dim j As Integer
    Dim k As Integer
    Dim WS As Worksheet
    Dim WordArr As Variant
    Dim DubStr As String
    Dim WordCount As Integer

    Set WS = ActiveSheet

    'Loop cells
    For i = 1 To WS.Cells(Rows.Count, 1).End(xlUp).Row
        'Split cell words into array
        WordArr = Split(WS.Cells(i, 1).Value, " ")

        'Loop through each word in cell
        For j = LBound(WordArr) To UBound(WordArr)
            WordCount = 0

            'Count the occurrences of the word
            For k = LBound(WordArr) To UBound(WordArr)
                If UCase(WordArr(j)) = UCase(WordArr(k)) Then
                    WordCount = WordCount + 1
                End If
            Next k

            'Output duplicate words to string
            If WordCount > 1 And InStr(1, DubStr, WordArr(j)) = 0 Then
                DubStr = DubStr & WordArr(j) & " "
            End If
        Next j

        'Paste string in column B
        WS.Cells(i, 2).Value = Trim(DubStr)
        DubStr = ""
        Erase WordArr
    Next i
End Sub

Upvotes: 1

Dick Kusleika
Dick Kusleika

Reputation: 33155

You could use a Dictionary object from the Scripting library. It has an Exists method that will tell you if a particular word already exists in the dictionary. Here's an example

Public Function ListDupes(ByVal rCell As Range) As String

    Dim vaInput As Variant
    Dim i As Long
    Dim dc As Scripting.Dictionary
    Dim dcOutput As Scripting.Dictionary

    'split the text into words
    vaInput = Split(rCell.Value, Space(1))

    'create dictionairys - one to hold all the words, one for the dupes
    Set dc = New Scripting.Dictionary
    Set dcOutput = New Scripting.Dictionary

    'loop through the words and add them to the output
    'dictionary if they're dupes, and to the other
    'dictionary if they're not
    For i = LBound(vaInput) To UBound(vaInput)
        If dc.Exists(vaInput(i)) Then
            dcOutput.Add vaInput(i), vaInput(i)
        Else
            dc.Add vaInput(i), vaInput(i)
        End If
    Next i

    'Join the dupes, separating by a space
    ListDupes = Join(dcOutput.Items, Space(1))

End Function

Upvotes: 1

Related Questions