如何实现Excel多选下拉框选中项不关闭，直至点击外部？

以下提供两种更友好的实现方案，解决原生下拉框选中即关闭的体验问题：

方案一：ActiveX ListBox控件（最优体验） #

该方案用ActiveX列表框模拟下拉框，支持连续多选、点击外部自动隐藏，视觉和交互更接近常规应用。

1. 控件设置 #

• 打开「开发工具」选项卡 → 「插入」→ 选择ActiveX控件中的ListBox（不要选表单控件）
• 调整控件大小与目标单元格匹配，右键控件→「属性」，设置核心参数：
  • MultiSelect：设为1 - fmMultiSelectMulti（支持勾选多选）
  • ListFillRange：指定选项数据源（如$A$1:$A$6）
  • Visible：设为False（初始隐藏）
  • MatchEntry：设为0 - fmMatchEntryNone（避免输入干扰）

2. VBA代码实现 #

右键工作表标签→「查看代码」，粘贴以下代码：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim targetArea As Range
    ' 定义需要触发下拉框的单元格范围，比如B2:B15
    Set targetArea = Me.Range("B2:B15")
    
    ' 点击外部区域隐藏列表框
    Me.ListBox1.Visible = False
    
    ' 选中目标单元格时显示列表框
    If Not Intersect(Target, targetArea) Is Nothing And Target.Cells.Count = 1 Then
        With Me.ListBox1
            .Top = Target.Top
            .Left = Target.Left
            .Width = Target.Width
            .Visible = True
            ' 预勾选已选中的选项
            Dim i As Integer
            Dim existingItems As String
            existingItems = Target.Value
            For i = 0 To .ListCount - 1
                .Selected(i) = InStr(1, existingItems, .List(i), vbTextCompare) > 0
            Next i
        End With
    End If
End Sub

Private Sub ListBox1_Click()
    Dim selectedText As String
    Dim i As Integer
    
    ' 拼接选中的选项（逗号分隔）
    selectedText = ""
    For i = 0 To Me.ListBox1.ListCount - 1
        If Me.ListBox1.Selected(i) Then
            selectedText = IIf(selectedText = "", "", selectedText & ", ") & Me.ListBox1.List(i)
        End If
    Next i
    
    ' 将结果写入当前选中的单元格
    Me.Range(Selection.Address).Value = selectedText
End Sub

Private Sub Worksheet_Deactivate()
    ' 切换工作表时隐藏列表框
    Me.ListBox1.Visible = False
End Sub

方案优势 #

• 选中选项时列表框保持展开，可连续勾选/取消
• 点击目标单元格外区域自动隐藏控件
• 支持记忆已选内容，再次点击单元格自动预勾选
• 视觉贴合单元格，交互流畅

方案二：优化原生数据验证下拉框（兼容性优先） #

如果需要保留原生数据验证的兼容性（比如共享文件时ActiveX可能触发安全提示），可基于原生下拉框改进VBA代码，实现选中不关闭：

VBA代码实现 #

右键工作表标签→「查看代码」，粘贴以下代码：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim dvRange As Range
    ' 筛选所有带下拉数据验证的单元格
    On Error Resume Next
    Set dvRange = Me.Cells.SpecialCells(xlCellTypeAllValidation)
    On Error GoTo 0
    
    If dvRange Is Nothing Then Exit Sub
    
    ' 选中目标单元格时展开下拉框
    If Not Intersect(Target, dvRange) Is Nothing And Target.Cells.Count = 1 Then
        If Target.Validation.Type = xlValidateList Then
            SendKeys "%{DOWN}" ' 模拟点击下拉箭头
        End If
    Else
        ' 点击外部区域退出下拉状态
        Application.CutCopyMode = False
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim oldValue As String
    Dim newValue As String
    
    ' 仅处理单个带下拉验证的单元格
    If Target.Cells.Count > 1 Then Exit Sub
    On Error Resume Next
    If Target.Validation.Type <> xlValidateList Then Exit Sub
    On Error GoTo 0
    
    Application.EnableEvents = False
    
    ' 用批注存储旧选中值（避免Undo失效）
    If Target.Comment Is Nothing Then
        Target.AddComment
        oldValue = ""
    Else
        oldValue = Target.Comment.Text
    End If
    newValue = Target.Value
    
    ' 新增/移除选中项
    If InStr(1, oldValue, newValue, vbTextCompare) = 0 Then
        Target.Value = IIf(oldValue = "", "", oldValue & ", ") & newValue
    Else
        ' 移除重复项
        Target.Value = Replace(Replace(oldValue, ", " & newValue, ""), newValue & ", ", "")
        Target.Value = Replace(Target.Value, newValue, "")
    End If
    
    ' 更新批注存储当前值
    Target.Comment.Text Text:=Target.Value
    
    ' 重新展开下拉框（核心：选中后不关闭）
    SendKeys "%{DOWN}"
    
    Application.EnableEvents = True
End Sub

方案优势 #

• 保留原生数据验证的外观和兼容性
• 选中选项后自动重新展开下拉框，支持连续选择
• 用批注存储已选内容，避免常规方案的Undo失效问题

内容的提问来源于stack exchange，提问作者Michael Norman