将 A 列中按空格分割的单词与 B 列中的字符串进行比较，如果 A 列中的所有单词都存在于 B 列的任何字符串中，则返回匹配

请测试下一个改编的代码。它将根据 B：B 中的所有单元格检查 A：A 中单元格中的相同拆分字符串，并将找到完全匹配的单元格涂成黄色（单词顺序无关紧要）：

Sub CompareWords()
    Dim ws As Worksheet, lastR As Long, xStr() As String, arrMtch() As String, arrAddress() As String, rngYellow As Range
    
    Dim i As Long, j As Long
    Dim x As Long, y As Long

    Set ws = ActiveSheet
    lastR = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    ReDim arrAddress(1 To lastR, 1 To 1) 'array to keep the addresses of cells from B:B where a match has been found
    
    'reset the columns appearence:
    ws.Range("A1:A" & lastR).Interior.Color = xlNone
    ws.Range("B1:B" & ws.Range("B" & ws.Rows.Count).End(xlUp).Row).Font.ColorIndex = xlAutomatic
    ws.Range("C1:C" & ws.Range("B" & ws.Rows.Count).End(xlUp).Row).ClearContents
    
    Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
    With ws
        For i = 1 To lastR
            xStr = Split(.Cells(i, "A").Value, " ")
            For j = 1 To .Cells(.Rows.Count, "B").End(xlUp).Row
                With .Cells(j, "B")
                    ReDim arrMtch(UBound(xStr)) 'redim the array keeping "OK" for all matches
                    For x = LBound(xStr()) To UBound(xStr())
                        For y = 1 To Len(.Text)
                            If Mid(.Text, y, Len(xStr(x))) = xStr(x) Then
                                 arrMtch(x) = "OK"
                            End If
                        Next y
                    Next x
                    If UBound(Filter(arrMtch, "OK", True)) = UBound(arrMtch) Then 'if all array elements are "OK"
                        addToRange rngYellow, ws.Cells(i, "A") 'place the cell in a Union range
                        arrAddress(i, 1) = .Address                       'place the cell from B:B address in the dedicated array
                        Exit For
                    End If
                End With
            Next j
        Next i
    End With
    If Not rngYellow Is Nothing Then rngYellow.Interior.Color = vbYellow
    ws.Range("C1").Resize(UBound(arrAddress), 1).Value = arrAddress
    Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
    MsgBox "Ready..."
End Sub

上面的代码在 C：C 列中写入 B：B 中单元格的地址，其中已找到匹配项。

请在相应的工作表代码模块中复制下一个事件代码。双击 A：A 中的（黄色）单元格时，B：B 中的匹配单元格在匹配的单词上显示颜色（红色）：

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Column = 1 Then
        If Target.Offset(, 2) <> "" Then
               Dim xStr() As String, x As Long, y As Long
                xStr = Split(Target.Value, " ")
                With Me.Range(Target.Offset(, 2).Value)
                        .Font.ColorIndex = xlAutomatic 'color the cell font in black
                        For x = LBound(xStr()) To UBound(xStr())
                            For y = 1 To Len(.Text)
                                    If Mid(.Text, y, Len(xStr(x))) = xStr(x) Then
                                        .Characters(y, Len(xStr(x))).Font.ColorIndex = 3
                                    End If
                                Next y
                        Next x
                        .Select
                End With
                Cancel = True
         End If
     End If
End Sub