Alphabetize Names within Single row on Multiple rows

**vnascimento** · 06-03-2013, 04:38 PM

Trying to alphabetize names in a single row separated by ";" I have long lists of names occupying single cells, example: 'Anne Ferguson; Allen Neale; Robert Gilday; Joseph McMilleon; James Kelcourse; Derek Kimball; Christian Scorzoni; Robert Lavoie; Donna McClure'. The format is correct and they all need to be in a single cell but I need them to be alphabetized as they are currently not. Example:

DEMO SET (Original)
Michael Franey; Kevin Donovan; Thomas Dion, III; R. Andrew Burbine; Kenneth Coyle
Pamela Harting-Barrat; Janet Adachi; David Clough; Michael Gowing; John Sonner
David Wojnar; Kevin Gaspar; Leslie Dakin
Paula Melville; Arthur Harrington; Michael Ouellette; John E. Duval; Scott Nichols
Dennis Perry; Robert Rossi; Christopher Johnson; Anthony Suffriti; Cecilia Calabrese; Paul Cavallo; James Cichetti; Gina Letellier; George Bitzas; Joseph Mineo; Donald Rheault
Raymond Wilcox; Charles Ketchen

DEMO SET (Desired Output)
R. Andrew Burbine; Kenneth Coyle; Thomas Dion, III; Kevin Donovan; Michael Franey
Janet Adachi; David Clough; Michael Gowing; Pamela Harting-Barrat; John Sonner
Leslie Dakin; Kevin Gaspar; David Wojnar
John E. Duval; Arthur Harrington; Paula Melville; Scott Nichols; Michael Ouellette
George Bitzas; Cecilia Calabrese; Paul Cavallo; James Cichetti; Christopher Johnson; Gina Letellier; Joseph Mineo; Dennis Perry; Donald Rheault; Robert Rossi; Anthony Suffriti
Charles Ketchen; Raymond Wilcox

I have 4 spreadsheets with 351 rows of data like that each, I can't mix them up so I need to do this for all 351 rows in each spreadsheet. Reorganizing all 1400+ cells alphabetically by hand would take longer than I can work on this so any way to automate it? I'm using Excel 2011, Mac version. Thanks!

**tigeravatar** · 06-03-2013, 05:17 PM

vnascimento,

Give this a try:

Sub tgr()
    
    Dim ws As Worksheet
    Dim wsTemp As Worksheet
    Dim rngSort As Range
    Dim SortCell As Range
    Dim lCalc As XlCalculation
    Dim arrData() As Variant
    Dim DataIndex As Long
    
    With Application
        lCalc = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    
    Set wsTemp = Sheets.Add
    On Error GoTo CleanExit
    
    For Each ws In ActiveWorkbook.Sheets
        If ws.Name <> wsTemp.Name Then
            Set rngSort = Intersect(ws.UsedRange, ws.Columns("A"))
            ReDim arrData(1 To rngSort.Rows.Count)
            DataIndex = 0
            For Each SortCell In rngSort.Cells
                DataIndex = DataIndex + 1
                If InStr(1, SortCell.Text, ";", vbTextCompare) > 0 Then
                    wsTemp.Range("A1").Value = SortCell.Text
                    wsTemp.Range("A1").TextToColumns wsTemp.Range("A1"), xlDelimited, Semicolon:=True, Comma:=False, Space:=False
                    wsTemp.Range("A1", wsTemp.Cells(1, Columns.Count).End(xlToLeft)).Copy
                    wsTemp.Range("A2").PasteSpecial xlPasteValues, Transpose:=True
                    With wsTemp.Range("A2", wsTemp.Cells(Rows.Count, "A").End(xlUp))
                        .Offset(, 1).Formula = "=TRIM(RIGHT(SUBSTITUTE(SUBSTITUTE(TRIM(A" & .Row & "),"", "",""_""),"" "",REPT("" "",255)),255))"
                        .Resize(, 2).Sort .Offset(, 1), xlAscending, Header:=xlNo
                        arrData(DataIndex) = Join(Application.Transpose(Evaluate("Index(Trim(" & .Address & "),)")), "; ")
                        wsTemp.UsedRange.Clear
                    End With
                Else
                    arrData(DataIndex) = SortCell.Text
                End If
            Next SortCell
            rngSort.Value = Application.Transpose(arrData)
        End If
    Next ws
    
CleanExit:
    wsTemp.Delete
    
    With Application
        .Calculation = lCalc
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
    If Err.Number <> 0 Then
        MsgBox Err.Description, , "Error: " & Err.Number
        Err.Clear
    End If
    
    Set ws = Nothing
    Set wsTemp = Nothing
    Set rngSort = Nothing
    Set SortCell = Nothing
    Erase arrData()
    
End Sub

**vnascimento** · 06-04-2013, 11:23 AM

That works, thanks a lot!

**tigeravatar** · 06-12-2013, 12:39 PM

I received this private message from the OP, vnascimento:

Originally Posted by vnascimento

Hi, you did me a big favor with the scrip on this thread http://www.excelforum.com/excel-prog...00#post3266200, however I'm having an issue now that when I try to run it in the actual sheet I get an "Error 13, mistmatch" I think it may have to do with the sample data not having any middle names, but some of the entries in the full data do, some are fully written out (John James Smith) and some abbreviated (John J. Smith) do you think that's why? Any way to make the script work with that? You would save me if you could help me out with this today. Thanks!

First the ugly part, from the Forum Rules:
4. Don't Private Message or email Excel questions to moderators or other members. (or Word, Access, etc.) The point of having a public forum is to share solutions to common (and sometimes uncommon) problems with all members.

As for your question, I added both John J. Smith and John James Smith to a couple of the rows in the sample data, and it sorted them just fine. Can you provide a new sample file where it is not sorting properly?

**jindon** · 06-12-2013, 02:33 PM

Process all in memory

Option Explicit

Sub test()
    Dim a, i As Long, mtch As Object, m As Object, temp, ii
    With Range("a1").CurrentRegion
        a = .Value
        With CreateObject("VBScript.RegExp")
            .Global = True
            For i = 1 To UBound(a, 1)
                If a(i, 1) Like "*;*" Then
                    .Pattern = "([^;]+)(?=(;|$))"
                    Set m = .Execute(a(i, 1))
                    ReDim temp(0 To 1, 0 To m.Count - 1)
                    .Pattern = "(\S+) (\S\.|[^\s\.]+)((?= )(\S+))?"
                    For ii = 0 To m.Count - 1
                        temp(0, ii) = Trim$(m(ii)): temp(1, ii) = Trim$(m(ii))
                        .Pattern = "^(\S\.)? *(\S+) (\S+)((, )?\S+)?$"
                        If .test(Trim$(m(ii))) Then
                            temp(1, ii) = .Replace(Trim$(m(ii)), "$3 $2")
                        Else
                            .Pattern = "^(\S+) (\S\.) (\S+)"
                            If .test(Trim$(m(ii))) Then
                                temp(1, ii) = .Replace(Trim$(m(ii)), "$3 $1")
                            End If
                        End If
                    Next
                    HSortM temp, 0, UBound(temp, 2), 1
                    a(i, 1) = Join(Application.Index(temp, 1, 0), "; ")
                End If
            Next
        End With
        .Value = a
    End With
End Sub

Private Sub HSortM(ary, LB, UB, ref, Optional ord As Boolean = 1)
    Dim m As Variant, i As Long, ii As Long, iii As Long, temp
    i = UB: ii = LB
    m = ary(ref, Int((LB + UB) / 2))
    Do While ii <= i
        If ord Then
            Do While ary(ref, ii) < m: ii = ii + 1: Loop
        Else
            Do While ary(ref, ii) > m: ii = ii + 1: Loop
        End If
        If ord Then
            Do While ary(ref, i) > m: i = i - 1: Loop
        Else
            Do While ary(ref, i) < m: i = i - 1: Loop
        End If
        If ii <= i Then
            For iii = LBound(ary, 1) To UBound(ary, 1)
                temp = ary(iii, ii): ary(iii, ii) = ary(iii, i): ary(iii, i) = temp
            Next
            ii = ii + 1: i = i - 1
         End If
    Loop
    If LB < i Then HSortM ary, LB, i, ref, ord
    If ii < UB Then HSortM ary, ii, UB, ref, ord
End Sub