怎样做到控件列表框分先后点击选中，按先后顺序依次填充到表格里。

wwz851025

怎样做到控件列表框分先后点击选中，按先后顺序依次填充到表格里。
有两个方案，能实现其中一个就行。

方案一，例如依次选中：

1，半背宽    2，全肩宽 3，全下摆 4，袖笼深 5，前领深  

之后按选择顺序依次填充到下面表格里。

方案二，若果依次选中，按顺序填充做不到。能不能做到这样操作：

1，双击A列的单元格激活列表框；

2，除非点击A列以外的表格，否则列表框始终不关闭，等待再次选择填充；

3，双击列表框内的名称，依次填充到激活的A列表格里；

4，鼠标点哪里，双击列表框内容就填充到哪里，填充一个表格自动下移。

哪位大师帮个忙，帮我修改一下代码，谢谢！

表格附件已经上传。

wwz851025

朱荣兴 发表于 2018-8-13 09:21
第二个方案可行

朱老师可以帮我改一下代码吗？ 第二个方案的

一把小刀闯天下

'这帖子好几天了吧，挺佩服楼主那没完没了的精神的，哈哈哈

'加了1个字典、3个listbox change事件，估计差不多，有问题留言

Option Explicit

Dim dx%, Myr&, dic

Private Sub CommandButton1_Click()
  If dic.Count > 0 Then ActiveCell.Resize(dic.Count) = Application.Transpose(dic.keys)
  Unload user
End Sub

Private Sub CommandButton3_Click()
  dx = 0: dic.RemoveAll
  With ListBox1: .MultiSelect = 1: End With
  With ListBox2: .MultiSelect = 1: End With
  With ListBox3: .MultiSelect = 1: End With
End Sub
Private Sub CommandButton4_Click()
  dx = 1: dic.RemoveAll
  With ListBox1: .MultiSelect = fmMultiSelectSingle: End With
  With ListBox2: .MultiSelect = fmMultiSelectSingle: End With
  With ListBox3: .MultiSelect = fmMultiSelectSingle: End With
End Sub

Private Sub CommandButton5_Click()
  dx = 1: dic.RemoveAll
  With ListBox1: .MultiSelect = fmMultiSelectSingle: End With
  With ListBox2: .MultiSelect = fmMultiSelectSingle: End With
  With ListBox3: .MultiSelect = fmMultiSelectSingle: End With
End Sub

Private Sub ListBox1_Click()
  If dx = 1 Then ActiveCell = ListBox1.Value: Unload user
End Sub

Private Sub ListBox2_Click()
  If dx = 1 Then ActiveCell = ListBox2.Value: Unload user
End Sub

Private Sub ListBox3_Click()
  If dx = 1 Then ActiveCell = ListBox3.Value: Unload user
End Sub

Private Sub ListBox1_Change()
  Dim t
  t = ListBox1.List(ListBox1.ListIndex)
  If dic.exists(t) Then
    If Not ListBox1.Selected(ListBox1.ListIndex) Then dic.Remove (t)
  Else
    If ListBox1.Selected(ListBox1.ListIndex) Then dic(t) = vbNullString
  End If
End Sub

Private Sub ListBox2_Change()
  Dim t
  t = ListBox2.List(ListBox2.ListIndex)
  If dic.exists(t) Then
    If Not ListBox2.Selected(ListBox2.ListIndex) Then dic.Remove (t)
  Else
    If ListBox2.Selected(ListBox2.ListIndex) Then dic(t) = vbNullString
  End If
End Sub

Private Sub ListBox3_Change()
  Dim t
  t = ListBox3.List(ListBox3.ListIndex)
  If dic.exists(t) Then
    If Not ListBox3.Selected(ListBox3.ListIndex) Then dic.Remove (t)
  Else
    If ListBox3.Selected(ListBox3.ListIndex) Then dic(t) = vbNullString
  End If
End Sub

Private Sub UserForm_Initialize()
  Dim Arr0, Arr1, Arr2, Erow As Integer
  With Worksheets("部位名称")
    Erow = .Range("A65536").End(xlUp).Row
    Arr0 = .Range("A2:a" & Erow)
    Erow = .Range("c65536").End(xlUp).Row
    Arr1 = .Range("C2:C" & Erow)
    Erow = .Range("e65536").End(xlUp).Row
    Arr2 = .Range("E2:E" & Erow)
  End With
  With user.ListBox1: .ColumnCount = 1: .BackColor = &HFFFF80: .List = Arr0: End With
  With user.ListBox2: .ColumnCount = 1: .BackColor = &H80FF80: .List = Arr1: End With
  With user.ListBox3: .ColumnCount = 1: .BackColor = &HFFC0FF: .List = Arr2: End With
  Set dic = CreateObject("scripting.dictionary")
End Sub

wwz851025

一把小刀闯天下 发表于 2018-8-13 13:48
'这帖子好几天了吧，挺佩服楼主那没完没了的精神的，哈哈哈

'加了1个字典、3个listbox change事件，估计 ...

老师您好，非常感谢您在百忙之中抽时间帮我解决问题。为了方便同事工作，提高工作效率，想到用此法。
受制于VBA的难度，实在解决不了，才来向大家求助。


我用了您做好的代码运行了一下，有一个bug出现。
点击“单选”之再回到“多选”时出现了截图上的这个弹窗问题
请问这个问题该怎么解决？

一把小刀闯天下

wwz851025 发表于 2018-8-13 16:34
老师您好，非常感谢您在百忙之中抽时间帮我解决问题。为了方便同事工作，提高工作效率，想到用此法。
受 ...

'每个listbox_change事件加了一个条件，再测试一下看看

'一般来说会有4个listbox,第4个listbox就是前3个box的选择结果，于是它也不存在单选与多选

'如果有问题双击第4个box把不符合项去除，优点在于可以看到所选项与项的顺序，，，

Option Explicit

Dim dx%, Myr&, dic

Private Sub CommandButton1_Click()
  If dic.Count > 0 Then ActiveCell.Resize(dic.Count) = Application.Transpose(dic.keys)
  Unload user
End Sub

Private Sub CommandButton3_Click()
  dx = 0: dic.RemoveAll
  With ListBox1: .MultiSelect = 1: End With
  With ListBox2: .MultiSelect = 1: End With
  With ListBox3: .MultiSelect = 1: End With
End Sub

Private Sub CommandButton4_Click()
  dx = 1: dic.RemoveAll
  With ListBox1: .MultiSelect = fmMultiSelectSingle: End With
  With ListBox2: .MultiSelect = fmMultiSelectSingle: End With
  With ListBox3: .MultiSelect = fmMultiSelectSingle: End With
End Sub

Private Sub CommandButton5_Click()
  dx = 1: dic.RemoveAll
  With ListBox1: .MultiSelect = fmMultiSelectSingle: End With
  With ListBox2: .MultiSelect = fmMultiSelectSingle: End With
  With ListBox3: .MultiSelect = fmMultiSelectSingle: End With
End Sub

Private Sub ListBox1_Click()
  If dx = 1 Then ActiveCell = ListBox1.Value: Unload user
End Sub

Private Sub ListBox2_Click()
  If dx = 1 Then ActiveCell = ListBox2.Value: Unload user
End Sub

Private Sub ListBox3_Click()
  If dx = 1 Then ActiveCell = ListBox3.Value: Unload user
End Sub

Private Sub ListBox1_Change()
  Dim t
  If ListBox1.ListIndex = -1 Then Exit Sub
  t = ListBox1.List(ListBox1.ListIndex)
  If dic.exists(t) Then
    If Not ListBox1.Selected(ListBox1.ListIndex) Then dic.Remove (t)
  Else
    If ListBox1.Selected(ListBox1.ListIndex) Then dic(t) = vbNullString
  End If
End Sub

Private Sub ListBox2_Change()
  Dim t
  If ListBox2.ListIndex = -1 Then Exit Sub
  t = ListBox2.List(ListBox2.ListIndex)
  If dic.exists(t) Then
    If Not ListBox2.Selected(ListBox2.ListIndex) Then dic.Remove (t)
  Else
    If ListBox2.Selected(ListBox2.ListIndex) Then dic(t) = vbNullString
  End If
End Sub

Private Sub ListBox3_Change()
  Dim t
  If ListBox3.ListIndex = -1 Then Exit Sub
  t = ListBox3.List(ListBox3.ListIndex)
  If dic.exists(t) Then
    If Not ListBox3.Selected(ListBox3.ListIndex) Then dic.Remove (t)
  Else
    If ListBox3.Selected(ListBox3.ListIndex) Then dic(t) = vbNullString
  End If
End Sub

Private Sub UserForm_Initialize()
  Dim Arr0, Arr1, Arr2, Erow As Integer
  With Worksheets("部位名称")
    Erow = .Range("A65536").End(xlUp).Row
    Arr0 = .Range("A2:a" & Erow)
    Erow = .Range("c65536").End(xlUp).Row
    Arr1 = .Range("C2:C" & Erow)
    Erow = .Range("e65536").End(xlUp).Row
    Arr2 = .Range("E2:E" & Erow)
  End With
  With user.ListBox1: .ColumnCount = 1: .BackColor = &HFFFF80: .List = Arr0: End With
  With user.ListBox2: .ColumnCount = 1: .BackColor = &H80FF80: .List = Arr1: End With
  With user.ListBox3: .ColumnCount = 1: .BackColor = &HFFC0FF: .List = Arr2: End With
  Set dic = CreateObject("scripting.dictionary")
End Sub

zpy2

感觉一般的软件很少有这样输入的，都是数据一行一行输入的，也可以用窗体，但是这样用的比较少。数据太多，最好是分配几个人输，然后再汇总。

wwz851025

一把小刀闯天下 发表于 2018-8-13 20:18
'每个listbox_change事件加了一个条件，再测试一下看看

'一般来说会有4个listbox,第4个listbox就是前3 ...

非常感谢老师不厌其烦和细心帮助，谢谢！

wwz851025

一把小刀闯天下 发表于 2018-8-13 20:18
'每个listbox_change事件加了一个条件，再测试一下看看

'一般来说会有4个listbox,第4个listbox就是前3 ...

老师下面的代码，导致除指定单元格A列外，其它单元格双击不能编辑，需要在编辑栏内编辑。
怎样可以让其它单元格不受其影响？

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) '双击单元格激活
    Cancel = True
    If Target.Column = 1 And Target.Row > 1 Then '指标列,1为A列**
       user.Show  '弹出窗口
       End If
End Sub