Option Explicit
Sub CompareNames()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim nameA As Variant
Dim nameB As Variant
Dim word As Variant
Dim matchFound As Boolean
' Set the worksheet to the active sheet
Set ws = ActiveSheet
' Find the last row with data in Column A or Column B
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
If ws.Cells(ws.Rows.Count, "C").End(xlUp).Row > lastRow Then
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
End If
' Loop through each row
For i = 1 To lastRow
nameA = Split(ws.Cells(i, 1).Value, " ")
nameB = Split(ws.Cells(i, 3).Value, " ")
' Initialize matchFound as False
matchFound = False
' Check if any word in nameA exists in nameB
For Each word In nameA
If IsNumeric(Application.Match(word, nameB, 0)) Then
matchFound = True
Exit For
End If
Next word
' Check if any word in nameB exists in nameA
If Not matchFound Then
For Each word In nameB
If IsNumeric(Application.Match(word, nameA, 0)) Then
matchFound = True
Exit For
End If
Next word
End If
' Place an "X" in Column C if a match is found
If matchFound Then
ws.Cells(i, 2).Value = "1"
Else
ws.Cells(i, 2).Value = "0"
End If
Next i
End Sub