【杂类】Excel使用vba下拉框多选(.xlsm .xls)

Option Explicit

'数据有效性选择可以多选,重复选
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
  '规定好哪一列的数据有效性是多选的，A列是第1列，B列是第2列，依次类推
  If Target.Column = 6 Then
    Application.EnableEvents = False
    newVal = Target.Value
    Application.Undo
    oldVal = Target.Value
    Target.Value = newVal
    If oldVal = "" Then
    '不做任何事情
    Else
      If newVal = "" Then
      '不做任何事情
      Else
        '去除重复的字段
        If InStr(1, oldVal, newVal) <> 0 Then
          Target.Value = oldVal
        Else '不是重复选项就视同增加选项
          Target.Value = oldVal & "|" & newVal
        End If
      End If
    End If
  End If
End If

exitHandler:
Application.EnableEvents = True
End Sub