How can I search for partial matching words in various columns without needing to provide search text?

I have a list of names in three columns - B2:B425, D2:406, & E2:30 where they were input by different people, so the names are worded differently. For example, I can have the name "Handler, Jones, & Wright" and someone else has the name listed as "Handler Corp." What I need is to find a formula or VBA macro code that can search through my list and notice the possible duplicates and highlight them. Since they are all different names, I cannot give it a unique "text" to search.

I found a code posted in this forum from some time ago (for two columns) but it highlighted all these names that had no partial words in common. Perhaps you can look over the code below and modify it for me or provide me with another one? Please let me know if you need any further information to guide me. 



Sub HighlightDups()
    Dim rg1 As Range, rg2 As Range, c As Range, d As Range
    Dim sTemp As String, sTempWords() As String, sTempDWords() As String
    Dim re As Object, mc As Object
    Dim i As Long, j As Long
    Dim sFirstAddress As String
 
Set rg1 = Range("B2", Cells(Rows.Columns.Count, "B").End(xlUp))
Set rg2 = Range("D2", Cells(Rows.Columns.Count, "D").End(xlUp))
 
Set re = CreateObject("vbscript.regexp")
    re.Global = True
    re.ignorecase = True
 
With Range(rg1, rg2)
    .Font.Color = vbBlack
    .Font.Bold = False
    .Interior.Color = xlNone
    .FormatConditions.Delete
End With
 
For Each c In rg1
  re.Pattern = "\b\w+\b"
  If re.test(c.Text) = True Then
    Set mc = re.Execute(c.Text)
        ReDim sTempWords(0 To mc.Count - 1)
        For i = 0 To UBound(sTempWords)
            sTempWords(i) = mc(i)
        Next i
           
    For i = 0 To UBound(sTempWords)
        Set d = rg2.Find(What:=sTempWords(i), _
                         LookIn:=xlValues, _
                         LookAt:=xlPart, _
                         MatchCase:=False)
        If Not d Is Nothing Then
            re.Pattern = "\b" & sTempWords(i) & "\b"
            sFirstAddress = d.Address
            Do
                   
                    If re.test(d.Text) Then
                With c
                    .Font.Color = vbWhite
                    .Font.Bold = True
                    .Interior.Color = vbBlue
                End With
                With d
                    .Font.Color = vbWhite
                    .Font.Bold = True
                    .Interior.Color = vbBlue
                End With
                    End If
                   
                Set d = rg2.FindNext(after:=d)
                Loop While Not d Is Nothing And d.Address <> sFirstAddress
        End If
    Next i
  End If
Next c
Set re = Nothing
End Sub