Excel下拉列表多选框实现

Excel提供了下拉列表的实现，但并不支持多选，后来慢慢找资料终于利用VBA编程实现了多选的问题。

首先点击视图->宏，工程资源所示：

有Microsoft Excel对象：对应的是Sheet1或Sheet2对像等;

窗体:对应的是弹出的对话框；

模块:对应的是调用某些功能的入口。

 

以Sheet1页单击D列为例弹出框供多选

1：

先建立宏，然后编辑，在"Microsoft Excel对象"中单击"Sheet2"的右键-》查看代码

将此代码保存：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)  //说明：监听sheet1发生的用户操作事件
    If ActiveCell.Column = 8 And ActiveCell.Row > 1 Then  //说明:当前激活列为J列，第二行以下
        Call ShowFM2  //调用显示窗体宏名
    End If
End Sub

 

2：

在工程资源-》"模块"对象 中 “插入模块”-》查看代码

保存如下代码：

Sub ShowFM()
   UserForm1.Show
End Sub

 

3：

在工程资源->"窗体"->插入"用户窗体"

然后在"工具箱"里拖放"列表框"和"命令按钮"到窗体上

接着点击"查看代码"

 

将以下代码保存：

 

Private Sub CommandButton1_Click()
Dim Arr(), k&, i&
ReDim Arr(1 To 1)
With ListBox1
    For i = 0 To .ListCount - 1
        If .Selected(i) Then
            k = k + 1
            ReDim Preserve Arr(1 To k)
            'Arr(k) = .List(i, 1)
            Arr(k) = Sheet2.Range("A" & (i + 1)).Value //获取Sheet2列表中A列i+1行的值
        End If
    Next i
End With
'MsgBox "您选择了：" & Join(Arr, ",")
UserForm1.Hide
'Application.ActiveSheet.Range("A1").Value = Join(Arr, ",")
Application.ActiveCell.Value = Join(Arr, ",") //将值放入到当前单元格
End Sub

Private Sub ListBox1_Click()
   
End Sub

Private Sub TextBox1_Change()

End Sub

Private Sub UserForm_Initialize()
With UserForm1.ListBox1
    .RowSource = "Sheet2!A1:A49"    '设定源数据区域 ，下拉列表框的数据来源
    .ColumnCount = 1               '设定列数
    .ColumnHeads = False             '设定列标题。标题为数据区域的上一行
    .BoundColumn = 2
    .MultiSelect = fmMultiSelectMulti       '按空格键或单击鼠标以选定列表中一个条目或取消选定。
'    .MultiSelect = fmMultiSelectExtended    '按 Shift 并单击鼠标，或按 Shift 的同时按一个方向键，将所选条目由前一项扩展到当前项。按 Ctrl 的同时单击鼠标可选定或取消选定。
'    .MultiSelect = fmMultiSelectSingle      '只可选择一个条目（默认）。
End With
End Sub

 

-----

 

保存试试看，不行的话看附件