让excel数据有效性序列可以多选

发表于 2019-4-26 17:04:58

将代码拷到ThisWorkbook里面。
测试文件：

（通用）让数据有效性序列可以多选.xlsm (19.79 KB, 下载次数: 149)

'Option Explicit '强制定义变量类型
Option Compare Text '可以让 AB=ab 成立，即不区分大小写，如果活省略或是把 TEXT换成 Binary 则区分大小写。
'该格式是对整个工作薄里面所有的表格起作用，所以应拷贝到ThisWorkbook里面。
'如果只想针对一个工作表起作用，拷贝到该工作表，并将下面一句换成 Sub Worksheet_Change(ByVal Target As Range)
Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'让数据有效性序列选择可以多选,重复选
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim Tpy As Integer
If Target.Count > 1 Then GoTo exitHandler
On Error Resume Next
Tpy = Target.Validation.Type
On Error GoTo 0
If Tpy <> 3 Then GoTo exitHandler
'-------------------------------------------------------------------------
Application.EnableEvents = False
newVal = Target.Value '取得新输入的值。
On Error Resume Next
Application.Undo '撤销刚才的输入，以便把没改前的值取得。
On Error GoTo 0
oldVal = Target.Value '取得没改之前的值。
If oldVal <> "" Then oldarr = Split(oldVal, ",")
If newVal <> "" Then newarr = Split(newVal, ",")
Dim Dic
Dim d As Integer, w As Integer
Set Dic = CreateObject("scripting.dictionary") '创建字典对象
If IsArray(oldarr) Then
For d = 0 To UBound(oldarr) Step 1
Dic(oldarr(d)) = ""
Next
End If
If IsArray(newarr) Then
For w = 0 To UBound(newarr) Step 1
Dic(newarr(w)) = ""
Next
End If
Rng = Dic.keys '返回字典key的数组
Set Dic = Nothing '销毁对象
n = UBound(Rng)
If n >= 0 Then
hbvar = Join(Rng, ",")
End If
If newVal = "" Then
Target.Value = newVal
Else
Target.Value = hbvar
End If
exitHandler:
Application.EnableEvents = True
End Sub

复制代码

帐号		自动登录	找回密码
密码			中文注册

[OFFICE] 让excel数据有效性序列可以多选

浏览过的版块