Sort Data Validation dropdown list within cell

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