formula to see if a surname is repeated within a cell and output a simplified string

Question

I have a list of several thousand items, which consist of several different names together like this:

Mr P Thompson & Mrs S Thompson & Mr A Thompson
Mr C Guy-Johnson & Mrs A Guye-Johnson & Miss J Guye-Johnson
Mrs Fuller & Ms D Fuller & Dr K U Fuller
Dr V Patel & Dr OO Patel
Mr B Burden & Mr MP Wood & Ms C Pollock
Mr PW Philips & Mrs PW Philips
Dr D Watson & S Holmes
Mr R Polanski & Mrs S Polanski
Mr S Spielberg & Miss G Spielberg & Mrs T Spielberg

Sometimes the surname is repeated within the cell, sometimes it is not.

I want to build a formula that will determine if the surname is repeated, and return a string where the Salutations/titles and inititals are concatenated with the Surname at the end, unless the surnames are different.

For example,

- Mr S Spielberg & Miss G Spielberg & Mrs T Spielberg
- Mr R Polanski & Mrs S Polanski

would become,

- Mr S & Miss G & Mrs T Spielberg
- Mr R & Mrs S Polanski

BUT:

- Mr B Burden & Mr MP Wood & Ms C Pollock
- Dr D Watson & S Holmes

would remain the same as the surnames are different

Is it possible to do that with formulas, (and not splitting the names using Text to Columns), and how would I do that please?

thanks Philip

Answer 1

I am sure Barry or Lori would come up with a smart formula :) However here is a VBA example which might just solve your boss's breathing problem ;)

Paste this code in a module. (Tested only with the samples in the screenshot below). I took the liberty to manipulate one of the cell values to take into consideration multiple matches in surnames. See Cell A1

Function GetNewNames(rng As Range) As String
    Dim MyAr() As String, tmpAr() As String
    Dim prevValue As String, sTmp As String, surName As String, sTemp As String
    Dim i As Long
    Dim col As New Collection
    Dim itm As Variant

    On Error GoTo Whoa:

    If Not rng Is Nothing Then
        prevValue = rng.Value

        If InStr(1, prevValue, "&") Then
            MyAr = Split(prevValue, "&")

            For i = 0 To UBound(MyAr)
                sTmp = Trim(MyAr(i))
                If InStr(1, sTmp, " ") Then
                    tmpAr = Split(sTmp, " ")
                    surName = tmpAr(UBound(tmpAr))
                Else
                    surName = sTmp
                End If

                On Error Resume Next
                col.Add surName, Chr(34) & surName & Chr(34)
                On Error Resume Next
            Next i

            For Each itm In col
                For i = 0 To UBound(MyAr)
                    sTmp = Trim(MyAr(i))

                    If InStr(1, sTmp, " ") Then
                        tmpAr = Split(sTmp, " ")
                        surName = tmpAr(UBound(tmpAr))
                    Else
                        surName = sTmp
                    End If

                    If surName = itm Then
                        If sTemp = "" Then
                            sTemp = Trim(MyAr(i))
                        Else
                            sTemp = Replace(sTemp & " & " & Trim(MyAr(i)), itm & " &", "&")
                        End If
                    End If
                Next i
            Next

            GetNewNames = sTemp
        Else
            GetNewNames = prevValue
        End If
    End If
    Exit Function
Whoa:
    GetNewNames = ""
End Function

Screenshot

Answer 2

In this task over the past week I found a use for this excellent formula by Mr Excel MVP Aladin Akyurek here which counts how many spaces are in a cell (used it to decide whether initials were needed as if no Salutaion or first name, only surname is used)

=LEN(A1)-LEN(SUBSTITUTE(A1," ",""))

On Ozgrid Forums Jindon came up with this Regex solution which gives me yet more encouragement to hit my O'Reilly Regular Expressions Cookbook again:

Sub test() 
    Dim r As Range, txt 
    With CreateObject("VBScript.RegExp") 
        .Pattern = "(.* )?(\S{3,})( .* )(\2)( .*)?" 
        For Each r In Range("a1", Range("a" & Rows.Count).End(xlUp)) 
            txt = r 
            Do While .test(txt) 
                txt = .Replace(txt, "$1$3$4$5") 
            Loop 
            r(, 2) = Application.Trim(txt) 
        Next 
    End With 
End Sub 

and on VBA Express forums SNB came up with this lovely array CSE formula

=SUBSTITUTE(A1,MID(A1,MAX((MID(A1,ROW(1:100),1)=" ")*ROW(1:100)),100),"")&MID(A1,MAX((MID(A1,ROW(1:100),1)=" ")*ROW(1:100)),100)

also on VBA Express forums mdmackillop came up with this lovely bit of clever thinking:

=SUBSTITUTE(A1,TRIM(RIGHT(SUBSTITUTE(TRIM(A1)," ",REPT(" ",50)),50))," ") & TRIM(RIGHT(SUBSTITUTE(TRIM(A1)," ",REPT(" ",50)),50))

which I modified and used as below:

=SUBSTITUTE(W:W,TRIM(RIGHT(SUBSTITUTE(TRIM(W:W)," ",REPT(" ",100)),100)) & " ","")

also on Mr Excel Forums Gerald Higgins proposed this which I found quite entertaining trying to break down and decode:

=SUBSTITUTE(A1," "&RIGHT(A1,LEN(A1)-FIND("ZZZ",SUBSTITUTE(A1," ","ZZZ",LEN(A1)-LEN(SUBSTITUTE(A1," ",""))))),"")&" "&RIGHT(A1,LEN(A1)-FIND("ZZZ",SUBSTITUTE(A1," ","ZZZ",LEN(A1)-LEN(SUBSTITUTE(A1," ","")))))

(but I had already handed in my work to my manager so had already made use of Sid's solution)