动态下拉菜单的疑问~还请各位高手指点指点，谢谢啦~

whatyang

下拉菜单.rar (4.46 KB, 下载次数: 29)

2013-12-7 23:35 上传

点击文件名下载附件

请各位高手指点，谢谢啦~！

zhaogang1960

短信收到，请测试：

1. Dim d As Object
   
2. 
   
3. Private Sub Worksheet_Activate()
   
4.     Call 设置字典
   
5. End Sub
   
6. 
   
7. Private Sub Worksheet_Change(ByVal Target As Range)
   
8.     If Target.Count > 1 Then Exit Sub
   
9.     If Intersect(Target, Range("E2:F65536")) Is Nothing Then Exit Sub
   
10.     If d Is Nothing Then Call 设置字典
    
11.     If Target.Column = 5 Then
    
12.         With Target.Offset(, 1).Validation
    
13.             .Delete
    
14.             .Add 3, 1, 1, Join(d.keys, ",")
    
15.         End With
    
16.     ElseIf Target.Column = 6 Then
    
17.         With Target.Offset(, 1).Validation
    
18.             .Delete
    
19.             If d.Exists(Target.Value) Then .Add 3, 1, 1, d(Target.Value)
    
20.         End With
    
21.     End If
    
22. End Sub
    
23. 
    
24. Sub 设置字典()
    
25.     Dim arr, i&
    
26.     Set d = CreateObject("scripting.dictionary")
    
27.     arr = Range("A1").CurrentRegion
    
28.     For i = 2 To UBound(arr)
    
29.         If InStr("," & d(arr(i, 2)), "," & arr(i, 3) & ",") = 0 Then d(arr(i, 2)) = d(arr(i, 2)) & arr(i, 3) & ","
    
30.     Next
    
31. End Sub

复制代码

zhaogang1960

请注意：此代码仅适应每次输入一个单元格
请看附件
下拉菜单.rar (11.57 KB, 下载次数: 120)

2013-12-8 00:19 上传

点击文件名下载附件

whatyang

zhaogang1960 发表于 2013-12-8 00:19
请注意：此代码仅适应每次输入一个单元格
请看附件

赵老师威武~但是您写的我看的不是很明白，不是太会改~

开始的时候我是用您很早之前的写的去重复项的一段，见下，红字部分改好了就好了，麻烦您看一下，谢谢~

Private Sub Worksheet_Change(ByVal Target As Range)
    With Target
        If .Row > 1 And .Column < 7 And .Column > 4 Then
            For i = 1 To .Rows.Count
                '初始化 部室、班组 下拉菜单
                If Len(Trim(Cells(.Row + i - 1, 5))) > 0 Then
                    er = Sheet1.Cells(Rows.Count, 2).End(xlUp).Row
                    If er = 1 Then er = 2
                    'BuShiArr = Sheet1.Range("b2:b" & er)
                    BuShiArr = Bcfz(Sheet1.Range("b2:b" & er))
                    BuShiStr = Join(BuShiArr, ",")
                    Cells(.Row + i - 1, 6).Locked = False
                    Cells(.Row + i - 1, 6).Validation.Delete
                    Cells(.Row + i - 1, 6).Validation.Add xlValidateList, Formula1:=BuShiStr
                    Cells(.Row + i - 1, 6).Validation.ShowError = False

                    BanZuArr = Bcfz(Sheet1.Range("b2:c" & er)) '这个地方不会写，求指点
                    BanZuStr = Join(BuShiArr, ",")
                    Cells(.Row + i - 1, 7).Locked = False
                    Cells(.Row + i - 1, 7).Validation.Delete
                    Cells(.Row + i - 1, 7).Validation.Add xlValidateList, Formula1:=BanZuStr
                    Cells(.Row + i - 1, 7).Validation.ShowError = False
                Else
                    Cells(.Row + i - 1, 6).Validation.Delete
                    Cells(.Row + i - 1, 7).Validation.Delete
                End If
            Next
        End If
    End With
End Sub

Function Bcfz(rng As Range)
     Dim d As Object, rCell As Range
     Set d = CreateObject("Scripting.Dictionary")
     On Error Resume Next
     For Each rCell In rng
         If Not d.exists(rCell.Text) Then
             If rCell <> "" Then
                 d.Add rCell.Text, 1
             End If
         End If
     Next rCell
     Bcfz = d.keys
     Set d = Nothing
' 函数用法
' Sub yy1()
' Dim rng As Range                ‘声明变量rng为区域对象
' Set rng = [a1:c10]                ‘把A1到C10单元格区域赋值给变量rng
' [d1].Resize(UBound(Bcfz(rng)) + 1, 1) = Application.Transpose(Bcfz(rng))
' End Sub
End Function
下拉菜单V2.rar (13.72 KB, 下载次数: 34)

2013-12-8 12:52 上传

点击文件名下载附件

zhaogang1960

whatyang 发表于 2013-12-8 12:52
赵老师威武~但是您写的我看的不是很明白，不是太会改~

开始的时候我是用您很早之前的写的去重复项的一 ...

这个程序速度会很慢，不改也罢
请说明你想到达的效果

whatyang

zhaogang1960 发表于 2013-12-8 13:02
这个程序速度会很慢，不改也罢
请说明你想到达的效果

就是您上面写的，加个多行（因为数据不一定是一个一个格子手工输入的，有可能是一次性粘贴上去的），然后如有数据删除时，数据有效性也清除掉~
（额，不过话说，一次性的运算量不是很大，所以对速度基本无要求~...呵呵~）

zhaogang1960

whatyang 发表于 2013-12-8 13:06
就是您上面写的，加个多行（因为数据不一定是一个一个格子手工输入的，有可能是一次性粘贴上去的），然后 ...

不记得了，可能是08年写的吧，那时还不会用字典，也不知道数组比区域快

whatyang

zhaogang1960 发表于 2013-12-8 13:09
不记得了，可能是08年写的吧，那时还不会用字典，也不知道数组比区域快

额，我的意思是您刚才上面才写的就是我要的东西，如果再加入 1.多行支持 2.数据删除时有效性随之删除 就完美了~  （您之前写的也是用字典的呀，不过是用区域的，没有用数组）

zhaogang1960

whatyang 发表于 2013-12-8 13:59
额，我的意思是您刚才上面才写的就是我要的东西，如果再加入 1.多行支持 2.数据删除时有效性随之删除 就完 ...

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     If Intersect(Target, Range("E2:F65536")) Is Nothing Then Exit Sub
   
3.     If d Is Nothing Then Call 设置字典
   
4.     Dim c As Range
   
5.     For Each c In Target
   
6.         If c.Column = 5 Then
   
7.             With c.Offset(, 1).Validation
   
8.                 .Delete
   
9.                 If Len(c.Value) Then .Add 3, 1, 1, Join(d.keys, ",") Else c.Offset(, 1) = ""
   
10.             End With
    
11.         ElseIf c.Column = 6 Then
    
12.             With c.Offset(, 1).Validation
    
13.                 .Delete
    
14.                 If d.Exists(c.Value) Then .Add 3, 1, 1, d(c.Value) Else c.Offset(, 1) = ""
    
15.             End With
    
16.         End If
    
17.     Next
    
18. End Sub
    

复制代码

zhaogang1960

请看附件
下拉菜单.rar (12.36 KB, 下载次数: 155)

2013-12-8 15:12 上传

点击文件名下载附件