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

 

[jindon]

How about

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 = "Co(rp|mpany|-?op)?$"
     If .test(txt) Then
          nicho = Array(txt,"")  '<- this lne was Arra(txt,""), missing "y"
          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

Note: Code edited typo

 

[Lewiy]

Here’s the tweak on my code:

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), " ", "")) = 2 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 guys....both great solutions. Captures about 99% out of a list of 10000 records! I am constantly amazed at the capacity of Excel. Thanks very much to both of you for your time and effort!

Nicho

 

[Nicho]

Hi Guys,

I have been asked for a variation on the above that will give me a joint salutation. So if you have Bill & Mary Smith they would like to additionally see a joint salutation of Bill & Mary in a separate column. If the name is Bill Smith & Mary Jones, they would like to see a joint salutation of Bill & Mary.

Possible?

Thanks,

Nicho

 

[jindon]

I don't understand why

If the name is Bill Smith & Mary Jones, they would like to see a joint salutation of Bill & Mary.

Is it only me?

 

[Nicho]

Hi Jindon,

This business sends out letters all the time. They would like to send out the letters to the first names. So they would like to send out a personalised letter to 'Dear Bill & Mary,".

I hope this makes sense?

Thanks,

Nicho

 

[jindon]

try

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 = "Co(rp|mpany|-?op)?$"
     If .test(txt) Then
          nicho = Array(txt,"")  '<- this lne was Arra(txt,""), missing "y"
          Exit Function
     End If
     .Pattern = "^(.+)\s(.+)\s&\s(.+)\s(.+)$"
     If .test(txt) Then
          nicho = .replace(txt,"$1 & $3")'<-here
          Exit Function
     End If
     .Pattern = "&"
     If Not .test(txt) Then
          nicho = Array(txt, "")
          Exit Function
     End If
End With
End Function

 

[Nicho]

Hey jindon,

Thanks for the follow up.

I am getting a compile syntax error at " nicho = .replace(txt,"$1 & $3)"

Any ideas?

Nicho

 

[jindon]

should be

nico = .replace(txt,"$1 & $3")

 

[Nicho]

Hey jindon,

This still gives me just the 2 separate names. Where should I look for the salutation? I highlighted b1:c1 and also b1:d1 and did the array as =nicho(a1).

Am I doing something wrong?

Nicho