Question

我是excel VBA的新手。我有大约20k行填充了A列中的描述。这些单词用空格分隔。我需要在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

您可以使用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

Answer 2

您可以使用以下代码：

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

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

2 个答案: