PDA

View Full Version : [SOLVED] Extract Last Name From A Cell



slink9
12-02-2004, 06:51 AM
I have a need to extract the last name from a row of cells. The name may be formatted as

John Smith
Mr & Mrs John Smith
Mr & Mrs John Smith, Jr
Mr & Mrs John Smith III

The column is A and I want to extract the last name into column E for last name sorting purposes. Any suggestions????

Brandtrock
12-02-2004, 09:34 AM
Stephen,

Here is an example file I have used for my courses. You will have to make adjustments to the column refs, but it shows how to do what you ask. I haven't accounted for the case where there is a comma though. That can be handled with another SUBSTITUTE being nested into the formula though.

Regards,

Zack Barresse
12-02-2004, 10:36 AM
Hello Steve,

Chip Pearson has about the best workaround for this that I've come across, found here (http://www.cpearson.com/excel/FirstLast.htm). His UDF solution looks as follows and handles JR, SR, II, III, IV and any suffix beginning with a number...



Function ParseOutNames(FullName As String) As Variant
Dim FirstName As String
Dim LastName As String
Dim MidInitial As String
Dim Suffix As String
Dim Pos As Integer
Dim Pos2 As Integer
Dim Pos3 As Integer
Pos = InStr(1, FullName, ",", vbTextCompare)
If Pos = 0 Then
Pos = Len(FullName) + 1
End If
LastName = Trim(Left(FullName, Pos - 1))
Pos2 = InStr(1, LastName, " ", vbTextCompare)
If Pos2 Then
Pos3 = InStr(Pos2 + 1, LastName, " ", vbTextCompare)
If Pos3 Then
Suffix = Right(LastName, Len(LastName) - Pos3)
LastName = Left(LastName, Pos3 - 1)
Else
Suffix = Right(LastName, Len(LastName) - Pos2)
LastName = Left(LastName, Pos2 - 1)
End If
End If
Pos2 = InStr(Pos + 2, FullName, " ", vbTextCompare)
If Pos2 = 0 Then
Pos2 = Len(FullName)
End If
If Pos2 > Pos Then
FirstName = Mid(FullName, Pos + 1, Pos2 - Pos)
MidInitial = Right(FullName, Len(FullName) - Pos2)
End If
Pos = InStr(1, LastName, "-", vbTextCompare)
If Pos Then
LastName = Trim(StrConv(Left(LastName, Pos), vbProperCase)) & _
Trim(StrConv(Right(LastName, Len(LastName) - Pos), vbProperCase))
Else
LastName = Trim(StrConv(LastName, vbProperCase))
End If
FirstName = Trim(StrConv(FirstName, vbProperCase))
MidInitial = Trim(StrConv(MidInitial, vbProperCase))
Suffix = Trim(StrConv(Suffix, vbProperCase))
' suffix handling
Select Case UCase(Suffix)
Case "JR", "SR", "II", "III", "IV", "MD", "PHD", "PH.D", "M.D."
Case Else
If Not IsNumeric(Left(Suffix, 1)) Then
LastName = LastName & " " & Suffix
Suffix = ""
End If
End Select
ParseOutNames = Array(LastName, FirstName, MidInitial, Suffix)
End Function

As an example, if you had your names (you posted above) starting in A1, to get the last name in B1, you'd select B1:E1 and enter ...


=ParseOutNames(A1)

Confirm with Ctrl + Shift + Enter, as it's an array formula. This will split the names up. A formula solution for the last name, also found on Chip's site, may look like this ...


=LEFT(A1,IF(ISERROR(FIND(",",A1,1)),LEN(A1),FIND(",",A1,1)-1))

This is also assuming the full name is in A1.



HTH

slink9
12-02-2004, 10:41 AM
It works excellently if there is always a postfix on the name (III, Esquire, etc) but fails when there is no postfix. Many in the list do not have one. In that case it displays the entire string after the Mr. or Mrs.
Did I do something wrong?

slink9
12-02-2004, 10:49 AM
firefytr,
Thanks. I will try that one now.

Zack Barresse
12-02-2004, 11:31 AM
Also, another solution as a routine, not a function, could look like ...


Option Explicit

Sub ParseSpacesPlease()
Dim cel As Range, rng As Range, i As Long, myVal As String, tmpVal As String
Set rng = Selection
For Each cel In rng
myVal = cel.Value
cel.Formula = "=TRIM(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(" & Chr(34) & _
myVal & Chr(34) & ",""Jr"",""""),""Sr"",""""),""III"",""""),"","",""""))"
tmpVal = cel.Value
For i = Len(tmpVal) To 1 Step -1
If Mid(tmpVal, i, 1) = Chr(32) Then
cel.Value = Right(tmpVal, Len(tmpVal) - i)
Exit For
End If
Next i
Next cel
End Sub

slink9
12-02-2004, 11:55 AM
firefytr,
I haven't actually used excel vba since completing the vba course. I can't get the result from the field properly. What is the proper order of steps to get it to work properly?

Zack Barresse
12-02-2004, 12:07 PM
For which solution? I've uploaded an example file. The two solutions are based on two different formats of names btw.


...

slink9
12-02-2004, 12:33 PM
parsenamesplease does just what I want. It just needs to reside in a cell and be an automatic thing. The person I am creating this for needs as much automated as possible. It will be hard enough to teach him how to sort the list and then merge into a mailing list.

slink9
12-02-2004, 12:34 PM
By the way, brandtrock's solution works as long as there is something after the last name, whether it is a space or a suffix.

Zack Barresse
12-02-2004, 12:41 PM
So what are you looking for here, a UDF? Or a routine that will guide this person through the process? A userform perhaps?

slink9
12-02-2004, 12:55 PM
He needs to be able to enter the name using the normal format into column A with the second, third, and occasionally fourth address lines in the next columns. I am guessing that I need a formula in column E that will automatically extract the name (as brandtrock's does properly with a space or suffix at the end) into column E.
He will then be able to sort this on column E and get an aplhabetical list.
I could have a UDF automatically fire after leaving column A, couldn't I? Which would be easier?

Zack Barresse
12-02-2004, 01:23 PM
If that is all he will be entering in that column, I'd suggest a worksheet_change event to enter the data in the relevant column (same row). You could use something like this (if you had the second solution of mine in a standard module) ...


Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim myVal As String
If Target.Row < 2 Then Exit Sub 'for header rows
If Target.Column <> 1 Then Exit Sub 'restrain to col A
If Target.Value = "" Then
Cells(Target.Row, 5).Value = ""
Else
If Cells(Target.Row, 5).Value = "" Then
myVal = ParseSpacesPlease(Target.Value)
Cells(Target.Row, 5).Value = myVal
End If
End If
End Sub

And the routine would be changed to a function like this ...


Option Explicit

Public Function ParseSpacesPlease(cel As String)
Dim i As Long, myVal As String, tmpVal As String, tmpCel As Range
Set tmpCel = Range("A65536").End(xlUp).Offset(1)
myVal = cel
Application.EnableEvents = False
tmpCel.Formula = "=TRIM(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(" & Chr(34) & _
myVal & Chr(34) & ",""Jr"",""""),""Sr"",""""),""III"",""""),"","",""""))"
tmpVal = tmpCel.Value
For i = Len(tmpVal) To 1 Step -1
If Mid(tmpVal, i, 1) = Chr(32) Then
cel = Right(tmpVal, Len(tmpVal) - i)
Exit For
End If
Next i
tmpCel.Clear
Application.EnableEvents = True
ParseSpacesPlease = cel
End Function

slink9
12-02-2004, 01:42 PM
Excellent.
Still one problem. He has at least one with a II suffix. I added II in the same format already there with another SUBSTITUTE but it didn't work. Is there another (or completely different) mod that needs to be made to handle that suffix?

slink9
12-02-2004, 01:46 PM
It didn't work with Jr. but I believe that is an easy fix. There is also a IV and I will need to incorporate that. He is an antiques dealer / appraiser so he has big money clients with big money names.

Zack Barresse
12-02-2004, 01:51 PM
Worksheet code ...


Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim myVal As String
If Target.Row < 2 Then Exit Sub 'for header rows
If Target.Column <> 1 Then Exit Sub 'restrain to col A
If Selection.Count > 1 Then Exit Sub
If Target.Value = "" Then
Cells(Target.Row, 5).Value = ""
Else
If Cells(Target.Row, 5).Value = "" Then
myVal = ParseSpacesPlease(Target.Value)
Cells(Target.Row, 5).Value = myVal
End If
End If
End Sub

Updated Function ...


Option Explicit

Public Function ParseSpacesPlease(cel As String)
Dim i As Long, myVal As String, tmpVal As String, tmpCel As Range
Set tmpCel = Range("A65536").End(xlUp).Offset(1)
myVal = cel
Application.EnableEvents = False
tmpCel.Formula = "=TRIM(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(" & Chr(34) & _
myVal & Chr(34) & ",""Jr"",""""),""Sr"",""""),""III"",""""),"","",""""),""II"",""""))"
tmpVal = tmpCel.Value
For i = Len(tmpVal) To 1 Step -1
If Mid(tmpVal, i, 1) = Chr(32) Then
cel = Right(tmpVal, Len(tmpVal) - i)
Exit For
End If
Next i
tmpCel.Clear
Application.EnableEvents = True
ParseSpacesPlease = cel
End Function

slink9
12-02-2004, 01:52 PM
I didn't realize that it would not replace the value. All fixed. Thanks.

Zack Barresse
12-02-2004, 01:55 PM
Okay. Glad you got it working Steve. :yes

brettdj
12-02-2004, 06:08 PM
My attempt with RegExp

Cheers

Dave



Sub GetProperLastName()
Dim MyRange As Range, Cel As Range
Dim RegEx As Object
Set MyRange = Range(Range("A1"), Range("A65336").End(xlUp))
Set RegEx = CreateObject("vbscript.regexp")
RegEx.Global = True
Application.ScreenUpdating = False
For Each Cel In MyRange
'strip out any combination of
'comma OR comma space(s) Or space(s) AND (Jn Or Snr Or III Or II Or IV Or I)
'Note that the longer strings should be replaced first, ie "III" before "II" etc
RegEx.Pattern = "(,|,\s{1,}|\s{1,})(Jr|Snr|III|II|IV|I)$"
Cel.Offset(0, 4) = RegEx.Replace(Cel.Value, "")
'get last word
RegEx.Pattern = ".+(\b[A-Za-z]+)$"
Cel.Offset(0, 4) = RegEx.Replace(Cel.Offset(0, 4), "$1")
Next
Application.ScreenUpdating = True
Set RegEx = Nothing
End Sub

NateO
12-03-2004, 04:28 PM
Hello slink9,

I can't tell if you want Jr and III to stay or go away...

if you want a native worksheet function that retains trailing identifiers, try the following in e1 for a1 and copy down:


=RIGHT(A1,LEN(A1)-FIND(CHAR(1),SUBSTITUTE(A1," ",CHAR(1),LEN(A1)-LEN(SUBSTITUTE(A1," ",""))-MIN(SUMPRODUCT((LEN(A1)-LEN(SUBSTITUTE(A1,{"Jr","III","IV","V","VI"},"")))),1))))

This is the first part to a longer function post here:
http://www.puremis.net/excel/MastersText/text_Nate.shtml#Q7

You can stack more trailing identifiers in the array if you like (in the braces: {}). The trailing identifiers shouldn't throw your sort off by much. ;)

slink9
12-03-2004, 05:03 PM
Zack's function worked beautifully and automatically. Thanks all.