PDA

View Full Version : Sort names



JLandrum
05-15-2015, 11:44 AM
I have a list of names in column A. (First M Last) not everyone has a middle.
Im trying to just sort column A by Last name first.
I used a formula which split the names into 2 separate columns.
it works but Im curious is there a way to sort Column A (first m last) by their last name without splitting it..
Thanks

Kenneth Hobs
05-15-2015, 01:14 PM
Without a logical structure for names, you will likely never have success if you have many names.

If you have an addon like Kutools or ASAP Utilities, you could do it but you don't need those. Using this macro, put it in a Module, select your range, run it, sort it, and run it again. Of course if you do that alot, it would be easier to just do it all in one macro using this sort of method with an array sort method or standard Excel sort. It just depends on the sort type.

Sub ReverseWords() Dim c As Range, s() As String, ss() As String, i As Integer, ii As Integer
For Each c In Selection
s() = Split(c.Value2)
ss() = s()
ii = LBound(s)
For i = UBound(s) To LBound(s) Step -1
ss(ii) = s(i)
ii = ii + 1
c.Value2 = Join(ss)
Next i
Next c
End Sub

JLandrum
05-15-2015, 01:34 PM
Im lost, I should have explained im a newbie to vba.

mperrah
05-15-2015, 02:16 PM
Try this.
I use column B and C to temporarily store the separated first and last names,
then sort and then remove the temp data.
You can move the columns to a few columns passed any data on your sheet.


Sub inStringTest()
Dim lr As Long, i As Long, X As Variant

Dim nM, fName, lName As String
Dim lSpc, rSpc As Integer

lr = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lr
nM = Cells(i, 1).Value
lSpc = InStr(nM, " ")
rSpc = InStrRev(nM, " ")
fName = Left(nM, lSpc - 1)
lName = Mid(nM, rSpc + 1)
Cells(i, 2).Value = fName ' column B gets first name - pick a different number for temp storage
Cells(i, 3).Value = lName ' column C gets last name
Next i
' sort
Columns("A:C").Select
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SortFields.Clear
.SortFields.Add Key:=Range("C1:C" & lr), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A1:C" & lr)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("B:C").ClearContents

End Sub

JLandrum
05-15-2015, 02:55 PM
Mark, that is awesome. FYI, it doesn't work with Suffix's. Ive been beating myself for hours trying to figure it out. Your great

mperrah
05-15-2015, 03:59 PM
It looks for the first space and the last space to account for middle names or no middle names.
but a suffix or prefix is another step.
how does the sheet get populated?
can you police the input

JLandrum
05-15-2015, 08:43 PM
The list is auto populated

mperrah
05-15-2015, 08:59 PM
I'll have to look into testing the right most letters in the name for 3 characters or less and full name containing more then 2 space sections. Not sure where to start for this

Aussiebear
05-16-2015, 03:11 PM
Can you set up a rule to ignore apostrophes, hyphens and full stops ( with the acompanying spaces) in the names?

mperrah
05-18-2015, 08:42 AM
Hello Aussiebear,

I found these Functions from tek-tips . com posted by Alex
I ran testing in varies name configurations and it is able to separate everything I threw at it.
Just need to re-configure these to be a sub rather than function if possible.


Public Function fTrimPrefix(InCol)

Dim OutCol As String

'replace " and " for entries containing "Mr. and Mrs."
OutCol = Replace(Replace(InCol, " and ", " "), " & ", " ")


'check for nulls
'this is only necessary when selecting case Instr value - 1
If InStr(OutCol, " ") > 1 Then

'remove first prefix if present
Select Case Left(OutCol, InStr(OutCol, " ") - 1)
Case "Miss", "Mr.", "Ms.", "Mrs.", "Dr.", "Rev.", "Capt.", "Rabbi"

OutCol = Trim(Mid(OutCol, InStr(OutCol, " ") + 1, Len(OutCol)))

Case Else

OutCol = OutCol

End Select

'remove second prefix if present
Select Case Left(Trim(OutCol), InStr(Trim(OutCol), " ") - 1)
Case "Miss", "Mr.", "Ms.", "Mrs.", "Dr.", "Rev.", "Capt.", "Rabbi"

OutCol = Trim(Mid(OutCol, InStr(Trim(OutCol), " ") + 1, Len(Trim(OutCol))))

Case Else

OutCol = OutCol

End Select

Else
OutCol = OutCol
End If

fTrimPrefix = OutCol

End Function

Public Function fTrimSuffix(InCol As String)

'I am running this twice --> fTrimSuffix(fTrimSuffix(FULLNAME))
'when I need to trim the suffix. I only want it to trim one at a time
'so that it can be used with the fGrabSuffix function in returning
'dual suffixes

Dim OutCol As String

OutCol = InCol

'Remove Suffix if present
Select Case Trim(Right(OutCol, InStr(StrReverse(OutCol), " ")))

Case "Sr.", "MD", "Jr.", "III", "IV", "V", "Jr", "Sr", "M.D.", "DDS", "Ret.", "USN" ' add more as needed

OutCol = Left(OutCol, Len(OutCol) - InStr(StrReverse(OutCol), " "))

'Remove Comma if present
OutCol = Replace(OutCol, ",", "")

Case Else

OutCol = OutCol

End Select

fTrimSuffix = OutCol

End Function

Public Function fGrabFName(InCol As String)

Dim OutCol As String

'first use fTrimPrefix to get a clean (left side of) name
OutCol = fTrimPrefix(InCol)

'Extract first name from cleaned name (everything up to first space)
If InStr(OutCol, " ") > 1 Then
OutCol = Left(OutCol, InStr(OutCol, " ") - 1)
End If
fGrabFName = OutCol

End Function

Public Function fGrabMName(InCol As String)

Dim OutCol As String

'first use fTrimPrefix and fTrimSuffix to get a clean name
OutCol = fTrimSuffix(fTrimSuffix(fTrimPrefix(InCol)))


'Check for a second, non-trailing space after the first to appear in string
Select Case InStr(Trim(Mid(OutCol, InStr(OutCol, " ") + 1, Len(OutCol))), " ")

'If there is one, extract middle name (between first and second spaces)
Case Is > 0

OutCol = Mid(OutCol, InStr(OutCol, " ") + 1, Len(Mid(OutCol, InStr(OutCol, " ") + 1, _
InStr(Mid(OutCol, InStr(OutCol, " ") + 1, Len(OutCol)), " "))))

'If no second space, return blank middle name
Case Else

OutCol = ""

End Select

fGrabMName = OutCol

End Function
Public Function fGrabLName(InCol As String)

Dim OutCol As String

'first use fTrimSuffix to get a clean (right side of) name
OutCol = fTrimSuffix(fTrimSuffix(InCol))

'Check for nulls
If InStr(OutCol, " ") > 1 Then
'Extract Last Name (everything after last space of cleaned name)
OutCol = Right(OutCol, InStr(StrReverse(OutCol), " ") - 1)
End If

fGrabLName = OutCol

End Function

Public Function fGrabPrefix(InCol)


Dim OutCol As String


OutCol = InCol

'Check for "Mr. and Mrs.", "Dr. and Mrs."
If Left(OutCol, 12) Like ("*r. and Mrs.") Then

OutCol = Left(OutCol, 12)

'Check for same using ampersand

ElseIf Left(OutCol, 10) Like ("*r. & Mrs.") Then

OutCol = Left(OutCol, 10)

Else

'Check for nulls
If InStr(OutCol, " ") > 0 Then
'Extract prefix if present
Select Case Left(OutCol, InStr(OutCol, " ") - 1)
Case "Miss", "Mr.", "Ms.", "Mrs.", "Dr.", "Rev.", "Capt.", "Rabbi"

OutCol = Left(OutCol, InStr(OutCol, " ") - 1)

Case Else

OutCol = ""

End Select

Else
OutCol = ""
End If
End If

fGrabPrefix = OutCol

End Function

Public Function fGrabSuffix(InCol)

Dim OutCol As String

OutCol = InCol

'Check for Nulls
If InStr(OutCol, " ") > 0 Then

'Extract Suffix if present
Select Case Trim(Right(OutCol, InStr(StrReverse(OutCol), " ")))

Case "MD", "Jr.", "Sr.", "III", "IV", "V", "Jr", "Sr", "M.D.", "DDS"

OutCol = Right(OutCol, InStr(StrReverse(OutCol), " ") - 1)

Case "Ret", "Ret."
'uses fTrimSuffix to get 'clean' name for first suffix
OutCol = Right(Trim(fTrimSuffix(OutCol)), InStr(StrReverse(OutCol), " ") - 2) & " " & _
Right(OutCol, InStr(StrReverse(OutCol), " ") - 1)

Case Else

OutCol = ""

End Select

Else

OutCol = ""

End If

fGrabSuffix = OutCol

End Function

Kenneth Hobs
05-18-2015, 09:12 AM
Using those routines, one could do it like this and add the sort later if needed. In this example, the full names are in column A and the Last, First are added to column B.

' Functions by Alex from, http://www.tek-tips.com/faqs.cfm?fid=6468

Sub LastCommaFirst()
Dim r As Range, c As Range, col As String, s As String

Set r = Range("A2", Range("A" & Rows.Count).End(xlUp))
col = "B"

For Each c In r
s = c.Value2
Range(col & c.Row).Value2 = fGrabLName(s) & ", " & fGrabFName(s)
Next c
End Sub

The code did not handle the suffix Sr. As I said, there are always issues that come up when one does this kind of thing. It is why databases are used for such.

mperrah
05-18-2015, 09:36 AM
So, insert the above functions into a module so they are in the workbook then make this the main sub to run.
It uses column B temporarily to insert just the last name then sort all rows and then clears the temp last name column
If your worksheet has pre-existing data in column B, the temp column can be targeted somewhere else... x, zz, xfd

Sub vbax52606()
Dim lr As Long, i As Long

Dim nM, fName, lName As String
Dim lSpc, rSpc As Integer

lr = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lr
Cells(i, 2).Value = fGrabLName(Cells(i, 1).Value)
Next i
' sort
Columns("A:B").Select
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SortFields.Clear
.SortFields.Add Key:=Range("B1:B" & lr), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A1:B" & lr)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("B:B").ClearContents

End Sub

-mark

mperrah
05-18-2015, 09:46 AM
Hello Kenneth,
Strange your test did not catch Sr.
Alex' code originally did not have Sr. but I added it and Sr as well.
And my tests caught both.
My post #12 just utilizes the fGrabLname portion but that function does call on the other portions (prefix, suffix...).

And I totally agree.
having the format of the incoming data structured can allow our subs to be so much simpler,
but there-in lies the exciting challenge of debugging...

:)

mperrah
05-18-2015, 09:54 AM
I added a second sort key for the suffix, it seems to sort correctly now.
it takes the last name first then the suffix.
I tested a jr and sr with same last name it sorts as I would expect.


Sub vbax52606b()
Dim lr As Long, i As Long

Dim nM, fName, lName As String
Dim lSpc, rSpc As Integer

lr = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lr
Cells(i, 2).Value = fGrabLName(Cells(i, 1).Value)
Cells(i, 3).Value = fGrabSuffix(Cells(i, 1).Value)
Next i
' sort
Columns("A:B").Select
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SortFields.Clear
.SortFields.Add Key:=Range("B1:B" & lr), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("C1:C" & lr), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A1:C" & lr)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("B:C").ClearContents

End Sub


I cant take credit for the function work, but this would be a great submission for the knowledge base.
I see many searches for name parsing.

mperrah
05-18-2015, 11:04 AM
Not sure why,
my post #14 would not sort the first name properly.
This is a sideways way to get there but it works.


Sub vbax52606_Q()

Dim lr As Long, i As Long

lr = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lr
Cells(i, 2).FormulaR1C1 = "=fGrabLName(RC[-1])"
Cells(i, 3).FormulaR1C1 = "=fGrabFName(RC[-2])"
Cells(i, 4).FormulaR1C1 = "=fGrabSuffix(RC[-3])"
Next i

Range("B1:D" & lr).Copy
Range("E1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SortFields.Clear
.SortFields.Add Key:=Range("E1:E" & lr) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("F1:F" & lr) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("G1:G" & lr) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A1:G" & lr)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("B1:G" & lr).ClearContents
Range("A1").Select

End Sub