在单元格中查找重复的单词并粘贴到下一列

我是新的excel VBA。 我在A列中有大约20k行填充描述。单词用空格分隔。 我需要find列A中可用的repeated words （不是字母），并将其粘贴到列B中，如下所示。

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

我通过互联网search，找不到所需的。 此链接帮助我删除重复。 我不想删除它们，但复制到下一列。

Answer 1

你可以使用如下代码：

 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 

Answer 2

您可以使用Scripting库中的Dictionary对象。 它有一个Exists方法，它会告诉你一个特定的单词是否已经存在于字典中。 这是一个例子

 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