字典嵌套联动复合框

32286685

请大师们帮我解决一下字典嵌套联动复合框的难题！

zhaogang1960

工作表代码:

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.     If Target.Column <> 2 Or Target.Row = 1 Or Target.Count <> 2 Then
   
3.         UserForm1.Hide
   
4.         Exit Sub
   
5.     End If
   
6.     UserForm1.Show 0
   
7. End Sub
   

复制代码

zhaogang1960

窗体代码:

1. Dim d As Object, ds As Object
   
2. 
   
3. Private Sub ListBox1_Click()
   
4.     If ListBox1.ListIndex = -1 Then Exit Sub
   
5.     ListBox2.List = d(ListBox1.Value).keys
   
6.     ListBox3.Clear
   
7.     ActiveCell.Value = ListBox1.Value
   
8. End Sub
   
9. 
   
10. Private Sub ListBox2_Click()
    
11.     If ListBox2.ListIndex = -1 Then Exit Sub
    
12.     ListBox3.List = ds(ListBox1.Value & ListBox2.Value).keys
    
13.     ActiveCell.Offset(, 1).Value = ListBox2.Value
    
14. End Sub
    
15. 
    
16. Private Sub ListBox3_Click()
    
17.     If ListBox3.ListIndex = -1 Then Exit Sub
    
18.     ActiveCell.Offset(, 2).Value = ListBox3.Value
    
19.     Me.Hide
    
20. End Sub
    
21. 
    
22. Private Sub UserForm_Initialize()
    
23.     Dim arr, i&
    
24.     Set d = CreateObject("scripting.dictionary")
    
25.     Set ds = CreateObject("scripting.dictionary")
    
26.     arr = Sheets("目录表").[a1].CurrentRegion
    
27.     For i = 2 To UBound(arr)
    
28.         If Not d.Exists(arr(i, 4)) Then Set d(arr(i, 4)) = CreateObject("scripting.dictionary")
    
29.         d(arr(i, 4))(arr(i, 5)) = ""
    
30.         If Not ds.Exists(arr(i, 4) & arr(i, 5)) Then Set ds(arr(i, 4) & arr(i, 5)) = CreateObject("scripting.dictionary")
    
31.         ds(arr(i, 4) & arr(i, 5))(arr(i, 7)) = ""
    
32.     Next
    
33.     ListBox1.List = d.keys
    
34. End Sub
    
35. 
    

复制代码

zhaogang1960

请看附件
字典嵌套数据关联.rar (199.87 KB, 下载次数: 145)

2013-6-10 21:53 上传

点击文件名下载附件

32286685

我想实现的是点击剂型（D列）弹出窗体，与药品名称（B列）单元格数据相关联的。

zhaogang1960

32286685 发表于 2013-6-10 22:44
我想实现的是点击剂型（D列）弹出窗体，与药品名称（B列）单元格数据相关联的。

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     If Target.Column <> 2 Or Target.Row = 1 Then Exit Sub
   
3.     If Target.Count > 1 Then Exit Sub
   
4.     If Target.Value = "" Then Exit Sub
   
5.     Dim arr, i&, c As Range
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Set ds = CreateObject("scripting.dictionary")
   
8.     With Sheets("目录表")
   
9.         Set c = .Range("c:c").Find(Target.Value, LookAt:=xlWhole)
   
10.         If Not c Is Nothing Then
    
11.             arr = .[a1].CurrentRegion
    
12.             For i = c.Row To .Range("c:c").Find(Target.Value, , LookAt:=xlWhole, SearchDirection:=xlPrevious).Row
    
13.                 If Not d.Exists(arr(i, 4)) Then Set d(arr(i, 4)) = CreateObject("scripting.dictionary")
    
14.                 d(arr(i, 4))(arr(i, 5)) = ""
    
15.                 If Not ds.Exists(arr(i, 4) & arr(i, 5)) Then Set ds(arr(i, 4) & arr(i, 5)) = CreateObject("scripting.dictionary")
    
16.                 ds(arr(i, 4) & arr(i, 5))(arr(i, 7)) = ""
    
17.             Next
    
18.         Else
    
19.             Exit Sub
    
20.         End If
    
21.     End With
    
22.     r = Target.Row
    
23.     UserForm1.ListBox1.List = d.keys
    
24.     UserForm1.Show
    
25. End Sub
    

复制代码

zhaogang1960

改为输入B列“药品名称”弹出窗体，与药品名称（B列）单元格数据相关联
请看附件
字典嵌套数据关联.rar (200.02 KB, 下载次数: 80)

2013-6-10 23:16 上传

点击文件名下载附件

zhaogang1960

改为输入B列“药品名称”，或点击剂型（D列）都可以：

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     If Target.Column <> 2 Or Target.Row = 1 Then Exit Sub
   
3.     If Target.Count > 1 Then Exit Sub
   
4.     If Target.Value = "" Then Exit Sub
   
5.     Call 设置(Target.Row)
   
6. End Sub
   
7. 
   
8. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
9.     If Target.Column <> 4 Or Target.Row = 1 Then Exit Sub
   
10.     If Target.Count > 1 Then Exit Sub
    
11.     If Target.Offset(, -2).Value = "" Then Exit Sub
    
12.     Call 设置(Target.Row)
    
13. End Sub
    
14. 
    
15. Sub 设置(t&)
    
16.     Dim arr, i&, c As Range, s$
    
17.     Set d = CreateObject("scripting.dictionary")
    
18.     Set ds = CreateObject("scripting.dictionary")
    
19.     s = Cells(t, 2).Value
    
20.     With Sheets("目录表")
    
21.         Set c = .Range("c:c").Find(s, LookAt:=xlWhole)
    
22.         If Not c Is Nothing Then
    
23.             arr = .[a1].CurrentRegion
    
24.             For i = c.Row To .Range("c:c").Find(s, , LookAt:=xlWhole, SearchDirection:=xlPrevious).Row
    
25.                 If Not d.Exists(arr(i, 4)) Then Set d(arr(i, 4)) = CreateObject("scripting.dictionary")
    
26.                 d(arr(i, 4))(arr(i, 5)) = ""
    
27.                 If Not ds.Exists(arr(i, 4) & arr(i, 5)) Then Set ds(arr(i, 4) & arr(i, 5)) = CreateObject("scripting.dictionary")
    
28.                 ds(arr(i, 4) & arr(i, 5))(arr(i, 7)) = ""
    
29.             Next
    
30.         Else
    
31.             Exit Sub
    
32.         End If
    
33.     End With
    
34.     r = t
    
35.     UserForm1.ListBox1.List = d.keys
    
36.     UserForm1.Show
    
37. End Sub
    

复制代码

zhaogang1960

请看附件
字典嵌套数据关联.rar (203.85 KB, 下载次数: 226)

2013-6-10 23:25 上传

点击文件名下载附件

32286685

zhaogang1960 发表于 2013-6-10 23:25
请看附件

对，就是这样的，太感谢您了