Dim i%, k%
Dim r
Dim s1$, s2$
For i = 2 To Range("a1").End(xlDown).Row
    For k = i + 1 To Range("a1").End(xlDown).Row
        If Range("d" & i).Value = Range("d" & k).Value Then
            If InStr(1, Range("d" & i).Value, " ") > 0 Then
                r = Split(Range("d" & i).Value, " ")
                s1 = LCase(Left(Trim(r(0)), 1) & Trim(r(1)))
                s2 = LCase(Trim(r(0)) & Trim(r(1)))
                If InStr(1, LCase(Range("c" & k).Value), s1) > 0 Or InStr(1, LCase(Range("c" & k).Value), s2) > 0 Then Range("a" & k).Value = "several emails for one name"
                If InStr(1, LCase(Range("c" & i).Value), s1) > 0 Or InStr(1, LCase(Range("c" & i).Value), s2) > 0 Then Range("a" & i).Value = "several emails for one name"
            End If
        End If
    Next k
Next i