修改VBA代码实现提取单元格中全部重复单词（Grand、Theft）

样本数据 #

Col A                           Col B
Grand Theft Auto Grand Theft    Grand,Theft

现有如下VBA宏代码，运行后仅能在C列得到第一个重复词“Grand”，需要修改代码以获取A列中全部重复单词（Grand、Theft）并输出到C列：

Sub Repeatwrd()
    Dim lastRow As Long
    Dim i As Long
    Dim cellValueA As String
    Dim cellValueB As String
    Dim wordsA As Variant
    Dim wordsB As Variant
    Dim wordIndex As Long
    Dim word As Variant
    Dim wordCount As Integer

    ' Get the last row of data in column A
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    ' Loop through each row of data in column A and compare with column B
    For i = 1 To lastRow
        ' Get the values in columns A and B for the current row
        cellValueA = Cells(i, 1).Value
        cellValueB = Cells(i, 2).Value
        
        ' Split the strings into words
        wordsA = Split(cellValueA, " ")
        wordsB = Split(cellValueB, " ")
        
        ' Loop through each word in column A
        For wordIndex = 0 To UBound(wordsA)
            ' If the word is not found in column B, highlight it in column A
            If InStr(cellValueB, wordsA(wordIndex)) = 0 Then
                word = wordsA(wordIndex)
                ' Highlight the word in column A
                Cells(i, 1).Characters(InStr(cellValueA, word), Len(word)).Font.ColorIndex = 3 ' Highlight in red
                'Add highlight word in c column
                'Cells(i, 3).Value = Cells(i, 3).Value & " " & word

            End If
        Next wordIndex
        
        
         ' Loop through each word in the string
        For Each word In wordsA
            ' Count the number of occurrences of the word in the string
            wordCount = UBound(Split(cellValueA, word)) - LBound(Split(cellValueA, word))
            
            ' If the word occurs more than once, paste it in column C for the current row
            If wordCount > 1 Then
                'ws.Cells(i, 3).Value = word
                 Cells(i, 3).Value = word
                Exit For ' Exit the loop once a repeated word is found
            End If
            ' If the word occurs more than once, paste it in column C for the current row
            If wordCount > 1 Then
                'ws.Cells(i, 3).Value = word
                 Cells(i, 3).Value = word
                Exit For ' Exit the loop once a repeated word is found
            End If
        Next word
 Next i
End Sub

修改后的代码 #

Sub Repeatwrd()
    Dim lastRow As Long
    Dim i As Long
    Dim cellValueA As String
    Dim cellValueB As String
    Dim wordsA As Variant
    Dim wordsB As Variant
    Dim wordIndex As Long
    Dim word As Variant
    Dim wordCount As Integer
    Dim repeatedWords As String
    Dim addedWords As Collection ' 用于去重，避免重复添加同一个单词

    ' 获取A列最后一行数据
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    ' 遍历每一行数据
    For i = 1 To lastRow
        ' 初始化变量，避免跨行数据干扰
        cellValueA = Cells(i, 1).Value
        cellValueB = Cells(i, 2).Value
        repeatedWords = ""
        Set addedWords = New Collection
        
        ' 拆分字符串为单词数组
        wordsA = Split(cellValueA, " ")
        wordsB = Split(cellValueB, " ")
        
        ' 保留原逻辑：高亮A列中不在B列的单词
        For wordIndex = 0 To UBound(wordsA)
            If InStr(cellValueB, wordsA(wordIndex)) = 0 Then
                word = wordsA(wordIndex)
                Cells(i, 1).Characters(InStr(cellValueA, word), Len(word)).Font.ColorIndex = 3 ' 红色高亮
            End If
        Next wordIndex
        
        ' 遍历A列单词，收集所有重复出现的单词
        For Each word In wordsA
            ' 计算单词出现次数
            wordCount = UBound(Split(cellValueA, word)) - LBound(Split(cellValueA, word))
            
            If wordCount > 1 Then
                ' 检查单词是否已添加，避免重复写入
                On Error Resume Next
                addedWords.Add word, Key:=CStr(word)
                On Error GoTo 0
                ' 若为新单词，拼接到结果字符串
                If Err.Number = 0 Then
                    repeatedWords = IIf(repeatedWords = "", word, repeatedWords & "、" & word)
                End If
            End If
        Next word
        
        ' 将所有重复单词写入C列
        Cells(i, 3).Value = repeatedWords
    Next i
End Sub

修改说明 #

• 移除原代码中重复的判断逻辑和Exit For语句，避免找到第一个重复词就终止循环
• 新增repeatedWords变量用于拼接所有重复单词，用、分隔保证可读性
• 新增addedWords集合实现去重，防止同一个重复词被多次写入
• 每行初始化临时变量，避免不同行的数据互相干扰
• 完整保留原代码中高亮A列不在B列单词的逻辑

内容的提问来源于stack exchange，提问作者Sudharsan R