Split multiple names....

[Nicho]

Hi,

I have and issue where I have name in one cell and need to separate them into 2 cells. Trouble is it is a combination of single names, husband and wife, and partners with different surnames. Sample of data is below:

Belinda Smith & Grant Jones
Janine
Ken & Marie Smith
Louie & Betty Johnson
Naomi Thomsoon & Craig Brown
Narele & Barry Day
Nicholas & Julie Smithson
S M Bole & Co
Jim Morris
Danielle & JohnSimpson

I would appreciate any advice.

Thanks,

Nicho

 

[Lewiy]

Can you explain what results you expect to get from the above data?

 

[Nicho]

Can you explain what results you expect to get from the above data?

Thanks for the response. I need to get to the following:

Belinda Smith
Grant Jones
Janine
Ken Smith
Marie Smith
Louie Johnson
Betty Johnson
Naomi Thomson
Craig Brown
Narele Day
Barry Day
Nicholas Smithson
Julie Smithson
S M Bole & Co
Jim Morris
Danielle Simpson
John Simpson

 

[Lewiy]

The following macro should work for the sample data you have given. Try it and see if you get any problems. I must admit, it's a tricky one this because there are so many variations of how the data can be laid out, however, this macro is done in such a way that more layout criteria can be added if necessary:

Sub SortNames()
Dim limit As Long
Dim limit2 As Long
Dim c As Long
Columns(2).Insert shift:=xlToRight
Columns(2).Insert shift:=xlToRight
limit = Cells(Rows.Count, 1).End(xlUp).Row
With WorksheetFunction
    For c = 1 To limit
        
        If Len(Cells(c, 1)) - Len(.Substitute(Cells(c, 1), " ", "")) = 0 Then
            Cells(c, 2) = Cells(c, 1)
        End If
    
        If Len(Cells(c, 1)) - Len(.Substitute(Cells(c, 1), " ", "")) = 1 Then
            Cells(c, 2) = Cells(c, 1)
        End If
        
        If Len(Cells(c, 1)) - Len(.Substitute(Cells(c, 1), " ", "")) = 3 Then
            If Mid(Cells(c, 1), .Find("@", .Substitute(Cells(c, 1), " ", "@", 1)) + 1, 1) = "&" Then
                Cells(c, 2) = Left(Cells(c, 1), .Find(" ", Cells(c, 1))) & Right(Cells(c, 1), Len(Cells(c, 1)) - .Find("@", .Substitute(Cells(c, 1), " ", "@", 3)))
                Cells(c, 3) = Right(Cells(c, 1), Len(Cells(c, 1)) - .Find("@", .Substitute(Cells(c, 1), " ", "@", 2)))
            End If
        End If
        
        If Len(Cells(c, 1)) - Len(.Substitute(Cells(c, 1), " ", "")) = 4 Then
            If Mid(Cells(c, 1), .Find("@", .Substitute(Cells(c, 1), " ", "@", 2)) + 1, 1) = "&" Then
                Cells(c, 2) = Left(Cells(c, 1), .Find("@", .Substitute(Cells(c, 1), " ", "@", 2)) - 1)
                Cells(c, 3) = Right(Cells(c, 1), Len(Cells(c, 1)) - .Find("@", .Substitute(Cells(c, 1), " ", "@", 3)))
                Else: Cells(c, 2) = Cells(c, 1)
            End If
        End If
    Next c
End With
limit = Cells(Rows.Count, 2).End(xlUp).Row + 1
limit2 = Cells(Rows.Count, 3).End(xlUp).Row
For c = 1 To limit2
    If Cells(c, 3) <> "" Then
        Cells(limit, 2) = Cells(c, 3)
        limit = limit + 1
    End If
Next c
Columns(3).Delete shift:=xlToLeft
End Sub

 

[Nicho]

Hey Lewiy...that is brilliant! Thanks for that....can I ask a favour? Could you provide me with a version that stops the script with the names in the cells adjacent? So if I have Bob and Jane Smith and Fred Morris & Betty Jones I end up with the following:

Bob & Jane Smith Jane Smith
Fred Smith &Betty Jones Fred Smith Betty Jones

Just basically stopping your script before you pile all the names into the second column?

Thanks very much for all your help

Nicho

 

[Nicho]

Hi Lewiy...cancel that last request as I figured it out. I have noticed a minor issue though....there are some names that have a middle name. e.g. John Paul Smith. Is this something that is easy to address or not?

thanks

Nicho

 

[jindon]

Nicho

Can you provide us a sample data with all the possible combinations and the rsults you want?

 

[Nicho]

Hi....sorry if I have not been clear. I would like to end up with 3 columns of data. Column A would have the raw names. Column B would have Name 1 and Column C would have Name 2.

Lewiy has done exactly what I need except it does not allow for 3 part names which I did not notice until I ran the script.....thanks!

Column A would start with:
Bob & Jane Smith
Fred Smith & Betty Jones
John Paul Smith

Column B would end up with:
Bob Smith
Fred Smith
John Paul Smith

Column C would end up with:
Jane Smith
Betty Jones
(Blank)

 

[jindon]

try
1) paste the code onto a Standard Module
2) use in cell like
Select 2 holizontal consecutive cells, e.g. B1:C1
=nicho(A1)
Then confirm with Ctrl + Shift + Enter (Array formula entry)
Hope this works

Function nicho(txt As String) As Variant
With CreateObject("VBScript.RegExp")
     .Pattern = "(\D+)\s&\s(\D+)\s(\D+)"
     If .test(txt) Then
          nicho = Array(.replace(txt, "$1 $3"), .replace(txt,"$2 $3"))
          Exit Function
     End If
     .Pattern = "(\D+){2,}&(\D+){2,}"
     If .test(txt) Then
          nicho = Split(txt, "&")
          Exit Function
     End If
     .Pattern = "&"
     If Not .test(txt) Then
          nicho = Array(txt, "")
          Exit Function
     End If
End With
End Function

 

[Nicho]

Ok..thanks Jindon....I now have 2 choices. Your method fixes everything but where I get S M Bole & Co it puts S M Bole in Column B and Co in Column C.

Lewiy's solution gets S M Bole & Co correct but leaves 3 part names blank in Column B.

If there is an easy answer from either of you then that is great but either way your input has been tremendous....

Thanks,

Nicho