document image

As you can see in the image in the first cell there is a test "Wei J 2020", the VBA code should search for all the words in the this text "Wei" "J" "2020" in all the string present in the column B, If all these word are present in one string , the it should highlight the text in column A which defines that it is a match.

As you can see that all the words in A1 are matching with the string in B2.

Could you please help me with this, I am not able to crack it.

Private Sub CompareWords()

    Dim xStr() As String
    Dim i As Long
    Dim x As Long, y As Long

    With ActiveSheet
        For i = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
            xStr = Split(.Cells(i, "A").Value, " ")
            With .Cells(i, "B")
                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
            End With
        Next i
    End With 
End Sub

Using the above code I am able to compare the words in A1 with B1, A2 with B2 and so on.....result image if string is present in same row but the requirement is the code searches the words in A1 in all the strings present in column B, and returns a match only if all the words are present in the same string.

Also this code changes the font color to red in column B if it's a match, instead can we highlight the word in column A if it's a match

CodePudding user response：

Please, test the next adapted code. It will check the same split string from a cell in A:A against all cells in B:B and color in yellow the cell where a full match has been found (the words order does not matter):

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

The above code writes in C:C column the address of the cell in B:B, where a match has been found.

Please, copy the next event code in the respective sheet code module. When execute a double click on a (yellow) cell from A:A, the matching cell from B:B is colored (in red) on the matching words:

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