在 Excel 下拉清单当选择多个项目 - 完全指南-英雄云拓展知识分享

Excel 下拉清单是确保资料一致性和易于输入的绝佳工具。但是，预设情况下，它们限制您只能选择一项。但是，如果您需要从同一个下拉清单当选择多个项目怎幺办？本综合指南将探讨在 Excel 下拉清单中启用多项选择、管理重复项、设定自订分隔符号和定义内涵这些清单的范围的方法。

• 使用VBA程式码
• 只需点击几下便可使用 tools for Excel

• 允许重复项目
• 删除任何现有项目
• 设定自订分隔符
• 设定指定范围
• 在受保护的工作表中履行

启用下拉清单中的多项选择

本节提供两类方法来帮助您在 Excel 中的下拉清单中启用多项选择。

使用VBA程式码

若要允许在下拉清单中进行多项选择，您可使用 Visual Basic利用程序 (VBA) 在 Excel 中。该脚本可以修改下拉清单的行动，使其成为多项选择清单。请按以下步骤操作。

第 1 步：开启工作表（程式码）编辑器

1. 开启包括要为其启用多项选择的下拉清单的工作表。
2. 右键单击工作表标签并选择 查看代码 从上下文菜单。

   

步骤2：使用VBA程式码

现在复制以下 VBA 程式码并将其贴上到开启的工作表（程式码）视窗中。

VBA 代码：在 Excel 下拉清单中启用多项选择。

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by  20240118
Dim xRng As Range
Dim xValue1 As String
Dim xValue2 As String
Dim delimiter As String
Dim TargetRange As Range
Set TargetRange = Me.UsedRange ' Users can change target range here
delimiter = ", " ' Users can change the delimiter here
If Target.Count > 1 Or Intersect(Target, TargetRange) Is Nothing Then Exit Sub
On Error Resume Next
Set xRng = TargetRange.SpecialCells(xlCellTypeAllValidation)
If xRng Is Nothing Then Exit Sub
Application.EnableEvents = False
xValue2 = Target.Value
Application.Undo
xValue1 = Target.Value
Target.Value = xValue2
If xValue1 <> "" And xValue2 <> "" Then
If Not (xValue1 = xValue2 Or _
InStr(1, xValue1, delimiter & xValue2) > 0 Or _
InStr(1, xValue1, xValue2 & delimiter) > 0) Then
Target.Value = xValue1 & delimiter & xValue2
Else
Target.Value = xValue1
End If
End If
Application.EnableEvents = True
On Error GoTo 0
End Sub

结果

只需点击几下便可使用 tools for Excel

如果您对 VBA 不满意，还有一个更简单的选择： Excel的tools's 多选下拉列表 特徵。这个使用者友善的工具简化了在下拉清单中启用多个选择的进程，提供了各种范围，例如特定范围、至今为止工作表、全部工作簿或所有开启的工作簿。另外，它还允许您自订分隔符号并轻鬆管理重复项，以满足您的不同需求。

后 安装 tools for Excel，转到 库工具 标签，选择 下拉列表 > 多选下拉列表。然后需要进行以下配置。

1. 指定要套用此功能的位置 设定范围 部份。
2. 指定贮存格中所选项目的分隔符号。
3. 决定文字方向。
4. 点击 OK.

结果

多选下拉清单的更多操作

本节搜集在资料验证下拉清单中启用多个选择时可能需要的不同场景。

允许下拉清单中出现重复的项目

当下拉清单中允许进行多项选择时，重复可能会成为问题。上面的 VBA 程式码不允许下拉清单中出现重复的项目。如果您需要保存重复的项目，请尝试本节中的 VBA 程式码。

VBA程式码：允许资料验证下拉清单中重复

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by  20240118
Dim xRng As Range
Dim xValue1 As String
Dim xValue2 As String
Dim delimiter As String
Dim TargetRange As Range
Set TargetRange = Me.UsedRange ' Users can change target range here
delimiter = ", " ' Users can change the delimiter here
If Target.Count > 1 Or Intersect(Target, TargetRange) Is Nothing Then Exit Sub
On Error Resume Next
Set xRng = TargetRange.SpecialCells(xlCellTypeAllValidation)
If xRng Is Nothing Then Exit Sub
Application.EnableEvents = False
xValue2 = Target.Value
Application.Undo
xValue1 = Target.Value
Target.Value = xValue2
If xValue1 <> "" And xValue2 <> "" Then
Target.Value = xValue1 & delimiter & xValue2
End If
Application.EnableEvents = True
On Error GoTo 0
End Sub

结果

现在，您可以从至今为止工作表的下拉清单当选择多个项目。若要重复下拉清单贮存格中的某个项目，请继续从清单当选取该项目。看截图：

从下拉清单中删除任何现有项目

从下拉清单当选择多个项目后，有时可能需要从下拉清单贮存格中删除现有项目。本节提供另外一段 VBA 程式码来帮助您完成此任务。

VBA程式码：从下拉清单贮存格中删除任何现有项目

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by  20240118
Dim xRngDV As Range
Dim TargetRange As Range
Dim oldValue As String
Dim newValue As String
Dim delimiter As String
Dim allValues As Variant
Dim valueExists As Boolean
Dim i As Long
Dim cleanedValue As String
Set TargetRange = Me.UsedRange ' Set your specific range here
delimiter = ", " ' Set your desired delimiter here
If Target.CountLarge > 1 Then Exit Sub
' Check if the change is within the specific range
If Intersect(Target, TargetRange) Is Nothing Then Exit Sub
On Error Resume Next
Set xRngDV = Target.SpecialCells(xlCellTypeAllValidation)
If xRngDV Is Nothing Or Target.Value = "" Then
' Skip if there's no data validation or if the cell is cleared
Application.EnableEvents = True
Exit Sub
End If
On Error GoTo 0
If Not Intersect(Target, xRngDV) Is Nothing Then
Application.EnableEvents = False
newValue = Target.Value
Application.Undo
oldValue = Target.Value
Target.Value = newValue
' Split the old value by delimiter and check if new value already exists
allValues = Split(oldValue, delimiter)
valueExists = False
For i = LBound(allValues) To UBound(allValues)
If Trim(allValues(i)) = newValue Then
valueExists = True
Exit For
End If
Next i
' Add or remove value based on its existence
If valueExists Then
' Remove the value
cleanedValue = ""
For i = LBound(allValues) To UBound(allValues)
If Trim(allValues(i)) <> newValue Then
If cleanedValue <> "" Then cleanedValue = cleanedValue & delimiter
cleanedValue = cleanedValue & Trim(allValues(i))
End If
Next i
Target.Value = cleanedValue
Else
' Add the value
If oldValue <> "" Then
Target.Value = oldValue & delimiter & newValue
Else
Target.Value = newValue
End If
End If
Application.EnableEvents = True
End If
End Sub

结果

此 VBA 程式码可以让您从下拉清单当选择多个项目，并轻鬆删除已选取的任何项目。要删除某个项目，只需从清单中再次选择它便可。

设定自订分隔符

上述VBA程式码中分隔符号设定为逗号。您可以将此变数修改成任何首选字符，以用作下拉清单选择的分隔符。您可以这样做：

可以看到，上面的VBA程式码都有下面这行：

delimiter = ", "

您只需针对需要将逗号更改成任何分隔符号便可。举例来看，您想要用分号分隔项目，请将行改成：

delimiter = "; "

delimiter = vbNewLine

设定指定范围

上述VBA程式码适用于至今为止工作表中的所有下拉清单。如果您只想将VBA程式码套用至特定范围的下拉列表，则可以在上述VBA程式码中指定范围，以下所示。

可以看到，上面的VBA程式码都有下面这行：

Set TargetRange = Me.UsedRange

您只需将该行更改成：

Set TargetRange = Me.Range("C2:C10")

在受保护的工作表中履行

假定您使用密码“保护工作表”123”并将下拉清单单元格设定为“解锁」 在启动保护之前，从而确保多选功能在保护后保持活动状态。但是，上述 VBA 程式码在这类情况下没法运作，本节介绍另外一个专门用于处理多选功能的 VBA 脚本在受保护的工作表中。

VBA程式码：在下拉清单中启用多重选择而不重复

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by  20240118
Dim xRng As Range
Dim xValue1 As String
Dim xValue2 As String
Dim delimiter As String
Dim TargetRange As Range
Dim isProtected As Boolean
Dim pswd As Variant
Set TargetRange = Me.UsedRange ' Set your specific range here
delimiter = ", " ' Users can change the delimiter here
If Target.Count > 1 Or Intersect(Target, TargetRange) Is Nothing Then Exit Sub
' Check if sheet is protected
isProtected = Me.ProtectContents
If isProtected Then
' If protected, temporarily unprotect. Adjust or remove the password as needed.
pswd = "yourPassword" ' Change or remove this as needed
Me.Unprotect Password:=pswd
End If
On Error Resume Next
Set xRng = TargetRange.SpecialCells(xlCellTypeAllValidation)
If xRng Is Nothing Then
If isProtected Then Me.Protect Password:=pswd
Exit Sub
End If
Application.EnableEvents = False
xValue2 = Target.Value
Application.Undo
xValue1 = Target.Value
Target.Value = xValue2
If xValue1 <> "" And xValue2 <> "" Then
If Not (xValue1 = xValue2 Or _
InStr(1, xValue1, delimiter & xValue2) > 0 Or _
InStr(1, xValue1, xValue2 & delimiter) > 0) Then
Target.Value = xValue1 & delimiter & xValue2
Else
Target.Value = xValue1
End If
End If
Application.EnableEvents = True
On Error GoTo 0
' Re-protect the sheet if it was protected
If isProtected Then
Me.Protect Password:=pswd
End If
End Sub

透过在 Excel 下拉清单中启用多项选择，您可以大幅度增强工作表的功能和变通性。不管您熟习 VBA 编码还是喜欢 tools 等更简单的解决方案，您现在都可以将标準下拉清单转换为动态的多选工具。有了这些技能，您现在就能够建立更动态且使用者友好的 Excel 文件。对那些渴望深入研究 Excel 功能的人，我们的网站具有丰富的教学。 在这里了解更多 Excel 提示和技能.

相干文章