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

Question

我是新来的excel VBA。我在A列中有大约20k行填充了说明。单词用空格分隔。我需要在列A中找到repeated words（不是字母），并将它们粘贴到列B中，如下所示。

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

我在互联网上搜索，我找不到需要的。 This link帮助我删除重复项。我不想删除它们，但复制到下一列。

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