sorting columns with more than 2 text entries

[Guest]

Data>Text to Columns>Next works well if all entries have a "single" first and
last name, eg, "Joe Smith". However, if there is a "Mary Joe Smith" listed,
how do I put only the last text entry into a new column? I am downloading
payment information from a PayPal account and want to sort by last name for
our lunches. Unfortunatley the "name" information (first, last, etc...) is
contained in a single cell.

 

[Guest]

Hi JAB!

Use this formula to extract the 1st name in cell A1: =LEFT(A1,FIND(" ",A1,1))
Use this formula to extract the last word (last name) in cell A1:
=RIGHT(A1,LEN(A1)-FIND("*",SUBSTITUTE(A1," ","*",LEN(A1)-LEN(SUBSTITUTE(A1,"
","")))))

Cheers,

 

[Norman Jones]

Hi JAB,

Try:

Sub SplitNames2()
'////////////////////////////////////////////////////
'// Parse Nane string into constituent names
'// As written requires any name to be selected
'///////////////////////////////////////////////////

Dim FullNames As Range
Dim SplitNames As Range
Dim cel As Range
Dim FirstCel As Range
Dim LastCel As Range
Dim Surname As Range
Dim suffix As Variant
Dim i As Long
Dim j As Long

suffix = Array("PhD", "BSc", "MSc", "MA", "BA", _
"I", "II", "III", "IV",
"Jr")

Set FullNames = ActiveCell.CurrentRegion.Resize(, 1)

FullNames.TextToColumns Destination:=FullNames(1), _
DataType:=xlDelimited, _
TextQualifier:=xlNone, _
ConsecutiveDelimiter:=True, _
Tab:=False, _
Semicolon:=False, _
Comma:=True, _
Space:=True, _
Other:=False, _
FieldInfo:=Array(Array(1, 1), _
Array(2, 1), Array(3, 1))

FullNames.Insert Shift:=xlToRight

Set SplitNames = FullNames.Offset(, 1).CurrentRegion

j = SplitNames.Columns.Count

For Each cel In FullNames
For i = LBound(suffix) To UBound(suffix)
Set LastCel = cel.End(xlToRight)
Set FirstCel = cel.Offset(, -1)

If UCase(LastCel.Value) = UCase(suffix(i)) Then
LastCel.Copy FirstCel
LastCel.ClearContents
Exit For
End If
Next
Set LastCel = cel.End(xlToRight)
Set Surname = cel.Offset(0, j - 1)

LastCel.Copy Surname
If Surname.Address <> LastCel.Address Then
LastCel.ClearContents
End If
Next

If Application.WorksheetFunction. _
CountA(SplitNames.Columns(j)) > 0 Then

If Application.WorksheetFunction. _
CountA(SplitNames.Columns(j - 1)) = 0 Then
SplitNames.Columns(j).Copy SplitNames.Columns(j - 1)
SplitNames.Columns(j).ClearContents
FullNames.Offset(, -1).Copy FullNames(1).Offset(, j - 1)
End If

End If

FullNames.Offset(, -1).Delete Shift:=xlToLeft

End Sub
'<<================================

Usage: Select any name in the list and run the above macro.

I regret that I am unable to ascribe credit for the macro as I no longer
have details of the author.

If you are not familiar with macros, you may wish to visit David McRitchie's
'Getting Started With Macros And User Defined Functions' at:

http://www.mvps.org/dmcritchie/excel/getstarted.htm