Sort Data Validation dropdown list within cell - excel

Question

I have implemented a data validation in-cell drop down list that I use to retain multiple values in a column of cells. Currently you can select from the dropdown list in any order and the cell will populate in that order. Is there a way to force the order to stay consistent with the list that is the source for my dropdown?
For example: My dropdown list is:
Jim
Tom
Bob
Aaron
The selections are made in this order:
Bob
Jim
Tom
I want the cell to display:
Jim, Tom, Bob
Below is my current VBA code for the data validation drop down list:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
' To allow multiple selections in a Drop Down List
Dim Oldvalue As String
Dim Newvalue As String
Application.EnableEvents = True
On Error GoTo Exitsub
If Target.Column = 13 Then
If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
GoTo Exitsub
Else
If Target.Value = "" Then
GoTo Exitsub
Else
Application.EnableEvents = False
Newvalue = Target.Value
Application.Undo
Oldvalue = Target.Value
If Oldvalue = "" Then
Target.Value = Newvalue
Else
If InStr(1, Oldvalue, Newvalue) = 0 Then
Target.Value = Oldvalue & ", " & Newvalue
Else
Target.Value = Oldvalue
End If
End If
End If
End If
End If
Exitsub:
Application.EnableEvents = True
End Sub
So, below is a quick example screenshot:
Basically, the code above (given to me by a former coworker, not of my own invention) lets me keep multiple selections from the list in the cell, separated by a comma. That works great, but the selections from the list are presented in the cell in the order they were chosen.
I need them to show up in the order they are in in the list. From the example, if someone chooses Bob, then Tom, then Ryan, the current code displays Bob, Tom, Ryan. I need the code to re-sort the selections to display as Tom, Bob, Ryan.

Answer 1

Try this out - some changes from your original version, including that if you select something already selected it is removed from the selection.
Private Sub Worksheet_Change(ByVal Target As Range)
' To allow multiple selections in a Drop Down List
Dim Oldvalue As String
Dim Newvalue As String
Dim rng As Range, rngToCheck As Range, listVals
'run some checks
If rng.Cells.Count > 1 Then Exit Sub '<< this first!
Set rngToCheck = Me.Range("A1,C1,D1,M1").EntireColumn '<< checking columns A,C,D, M
Set rng = Application.Intersect(Target, _
rngToCheck.SpecialCells(xlCellTypeAllValidation))
If rng Is Nothing Then Exit Sub
If rng.Value <> "" Then
On Error GoTo Exitsub
Application.EnableEvents = False
Newvalue = rng.Value
Application.Undo
Oldvalue = rng.Value
If Oldvalue = "" Then
rng.Value = Newvalue
Else
listVals = Application.Evaluate(rng.Validation.Formula1).Value
rng.Value = SortItOut(listVals, Oldvalue, Newvalue) '<< call function
End If
End If
Exitsub:
If Err.Number > 0 Then Debug.Print Err.Description
Application.EnableEvents = True
End Sub
'Figure out what gets added (or removed) and keep
' it all in the same order as the validation source range
Private Function SortItOut(listVals, oldVal, newVal)
Const THE_SEP As String = ", "
Dim i As Long, arr, s, sep, t, listed, removeNewVal
s = ""
sep = ""
arr = Split(oldVal, THE_SEP)
'new value already listed?
removeNewVal = Not IsError(Application.Match(newVal, arr, 0))
For i = 1 To UBound(listVals, 1)
t = listVals(i, 1)
listed = Not IsError(Application.Match(t, arr, 0))
If listed Or newVal = t Then
If Not (removeNewVal And newVal = t) Then
s = s & sep & t
sep = THE_SEP
End If
End If
Next i
SortItOut = s
End Function

Answer 2

You can add this at the top:
Dim nameArray() As String
Dim sortedArray() As Variant: sortedArray = Array("Tom", "Bob", "Ryan") 'etc whatever order you need
Dim finalArray() As Variant
Dim spot1 As Integer
Dim spot2 As Integer: spot2 = 0
Dim name as String
And also include this right under Target.Value = Oldvalue & ", " & Newvalue :
Target.Value = Replace(Target.Value, ",", "")
nameArray = Split(Target.Value)
For spot1 = 0 To UBound(nameArray)
For Each name in nameArray
If name = sortedArray(spot1)
finalArray(spot2) = name
spot2 = spot2 + 1
End If
Next
Next
Target.Value = ""
For spot1 = 0 To UBound(finalArray)
If spot1 <> UBound(finalArray) Then
Target.Value = Target.Value & finalArray(spot1) & ", "
Else
Target.Value = finalArray(spot1)
End If
Next
Couldn't test it myself so make sure u save your file before testing.
Best of luck