CODEWITHSUNDEEP
excelvba
J Welsh
J Welsh

Reputation: 1

Sort Data Validation dropdown list within cell

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:

The selections are made in this order:

I want the cell to display:

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: 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.

Upvotes: 0

Views: 1032

Answers (2)

Tim Williams
Tim Williams

Reputation: 166366

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

Upvotes: 1

Kubie
Kubie

Reputation: 1571

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

Upvotes: 0

Related Questions