对单元格内的数据验证下拉列表进行排序

Question

我已经实现了一个单元格内的数据验证下拉列表，我用它来在一列单元格中保留多个值。目前，您可以按任何顺序从下拉列表中进行选择，并且单元格将按该顺序填充。有没有办法强制订单与作为我的下拉列表来源的列表保持一致？

例如：我的下拉列表是：

• 吉姆
• 汤姆
• 鲍勃
• 亚伦

选择按以下顺序进行：

• 鲍勃
• 吉姆
• 汤姆

我希望单元格显示：

• Jim, Tom, Bob

以下是我当前用于数据验证下拉列表的 VBA 代码：

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

所以，下面是一个简单的示例截图：

基本上，上面的代码（由前同事给我，不是我自己发明的）让我可以从单元格中的列表中保留多个选择，用逗号分隔。这很好用，但是列表中的选择会按照它们被选择的顺序显示在单元格中。

我需要它们按照它们在列表中的顺序显示。从示例中，如果有人选择Bob，然后选择Tom，然后选择Ryan，则当前代码显示Bob, Tom, Ryan。我需要代码来重新排序选择以显示为Tom, Bob, Ryan。

Answer 1

试试这个 - 对您的原始版本进行一些更改，包括如果您选择了已选择的内容，则会将其从选择中删除。

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

您可以在顶部添加：

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

并在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

无法自己测试，因此请确保在测试前保存文件。

祝你好运