excel如何实现下拉框复选

Private Sub Worksheet_Change(ByVal Target As Range)

' Developed by Contextures Inc.

' www.contextures.com

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

   'do nothing

Else

  Application.EnableEvents = False

  newVal = Target.Value

  Application.Undo

  oldVal = Target.Value

  Target.Value = newVal

  If Target.Column = 7 Then '这里规定好哪一列的数据有效性是多选的，A列是第1列，依次类推，如3就是C列，7就是G列

    If oldVal = "" Then

      'do nothing

      Else

      If newVal = "" Then

      'do nothing

      Else

        If InStr(1, oldVal, newVal) <> 0 Then  '重复选择视同删除

          If InStr(1, oldVal, newVal) + Len(newVal) - 1 = Len(oldVal) Then '最后一个选项重复

            Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 1)

          Else

            Target.Value = Replace(oldVal, newVal & ",", "") '不是最后一个选项重复的时候处理逗号

          End If

        Else '不是重复选项就视同增加选项

        Target.Value = oldVal & "," & newVal

'      NOTE: you can use a line break,

'      instead of a comma

'      Target.Value = oldVal _

'        & Chr(10) & newVal

        End If

      End If

    End If

  End If

End If

  

exitHandler:

  Application.EnableEvents = True

End Sub