Editing names

[nk18]

Hi,

Could someone please help me with the following problem:

I have a list of names eg.

Mr John Smith
Mrs Jane June Doe
Dr Stephen Paul William Smth etc.

I would like to change them into two formats:

Mr Smith (title and surname)
&
Mr J J Smith (title, intial(s) and surname)

As there is no set length for the names I have struggled using the replace and substitute functions but to no avail. Is it possible to solve this with a formula? Any help would be very much appreciated.

Thanks,

 

[jindon]

Hi

really not sure if this is correct or nor

Sub SplitName()
Dim i As Long, ii As Integer, LastR As Long, r As Range
Dim x() As String, ttl As String, Intl As String, z() As String
x = Split("Mrs ,Mrs.,Mr,Mr.,Miss,Ms,Ms.,Dr,Dr.", ",")
Application.ScreenUpdating = False
With ActiveSheet
    LastR = .Range("a65536").End(xlUp).Row
    For Each r In .Range("a1", .Range("a65536").End(xlUp))
        For i = LBound(x) To UBound(x)
            If InStr(UCase(r), UCase(x(i))) > 0 Then
                ttl = Trim(x(i))
                Exit For
            End If
        Next
        ii = 0
        For i = 1 To Len(r)
            If Mid(r, i, 1) = " " Then
                ii = ii + 1
                ReDim Preserve z(1 To ii)
                z(ii) = i
            End If
        Next
        For i = 1 To UBound(z) - 1
            Intl = Intl & " " & Mid(r, z(i) + 1, 1)
        Next
        r.Offset(, 1) = ttl & Mid(r, InStrRev(r, " "), 9 * 9)
        r.Offset(, 2) = ttl & Intl & Mid(r, InStrRev(r, " "), 9 * 9)
        ttl = ""
        Intl = ""
        Erase z
    Next
End With
Application.ScreenUpdating = True
End Sub

hope this helps
jindon

 

[nk18]

Thanks jindon.