Excel-多选下拉列表-无重复选择 [英] Excel - Multiple selection drop down list - no duplication of selection

问题描述

我已经在我的Excel电子表格上开发出，可以使用以下代码在下拉列表中选择多个项目：

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
If Target.Count > 1 Then GoTo exitHandler

On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler

If rngDV Is Nothing Then GoTo exitHandler

If Intersect(Target, rngDV) Is Nothing Then

Else
  Application.EnableEvents = False
  newVal = Target.Value
  Application.Undo
  oldVal = Target.Value
  Target.Value = newVal
    If oldVal = "" Then

      Else
      If newVal = "" Then

      Else
      Target.Value = oldVal _
        & ", " & newVal

      End If
    End If
End If


exitHandler:
  Application.EnableEvents = True
End Sub

但是，我现在要验证下拉列表项只能选择一次的答案。最好是，如果用户再次选择该项目，则将其删除。

如有任何帮助，我们将不胜感激。

推荐答案

试试：

Private Sub Worksheet_Change(ByVal Target As Range)
    Const SEP As String = ", "
    Dim rngDV As Range
    Dim oldVal As String
    Dim newVal As String
    Dim arr, m, v
    If Target.Count > 1 Then GoTo exitHandler

    On Error Resume Next
    Set rngDV = Target.SpecialCells(xlCellTypeSameValidation)
    On Error GoTo exitHandler
    If rngDV Is Nothing Then Exit Sub

    newVal = Target.Value
    If Len(newVal) = 0 Then Exit Sub 'user has cleared the cell...

    Application.EnableEvents = False

    Application.Undo
    oldVal = Target.Value

    If oldVal <> "" Then
        arr = Split(oldVal, SEP)
        m = Application.Match(newVal, arr, 0)
        If IsError(m) Then
            newVal = oldVal & SEP & newVal
        Else
            arr(m - 1) = ""
            newVal = ""
            For Each v In arr
                If Len(v) > 0 Then newVal = newVal & IIf(Len(newVal) > 0, SEP, "") & v
            Next v
        End If
        Target.Value = newVal
    End If

exitHandler:
      Application.EnableEvents = True
End Sub

这篇关于Excel-多选下拉列表-无重复选择的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！