[已解决]有效性如何突破字符限制

hgdzhh

数据有效性二级联动菜单，因为字符多，不能全部显示，请求帮助。
限制在B4和C4中
二级有效性下拉菜单—求助.rar (32.18 KB, 下载次数: 12)

2014-10-24 09:11 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

zjdh

2014-10-25 08:39

hgdzhh 发表于 2014-10-25 08:20
感谢各位的帮助，还是有点不理想，A、B列都有很多重复的数据，需要筛选出唯一的

这简单，原附件A列重复已处理了，看你B列没有重复就没考虑。
简单修改已达到你要求。
(, 下载次数: 9)

上传

点击文件名下载附件

跳转到最佳答案楼层

这儿有肥猫

如果一级菜单少的话，直接设置一下就好了,多的话就用宏

缔造者

“查询”工作表代码：
此代码有错误

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2. If Target.Count > 1 Then Exit Sub
   
3. If Target.Address <> "$B$3" And Target.Address <> "$C$3" Then Exit Sub
   
4. Dim arr, k
   
5. Dim i As Long
   
6. Dim d As Object, dic As Object
   
7. Set d = CreateObject("scripting.dictionary")
   
8. Set dic = CreateObject("scripting.dictionary")
   
9. arr = Worksheets("数据").Range("a3").CurrentRegion
   
10. For i = 3 To UBound(arr) - 1
    
11. If Not d.exists(arr(i, 1)) Then
    
12. d(arr(i, 1)) = arr(i, 1)
    
13. dic(arr(i, 1)) = arr(i, 2)
    
14. Else
    
15. dic(arr(i, 1)) = dic(arr(i, 1)) & "," & arr(i, 2)
    
16. End If
    
17. Next i
    
18. If Target.Address = "$B$3" Then
    
19. Range("c3").Validation.Delete
    
20. Range("c3").ClearContents
    
21. 
    
22. With Range("b3").Validation
    
23.         .Delete
    
24.         .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
    
25.         Operator:=xlBetween, Formula1:=Join(d.keys, ",")
    
26.     End With
    
27. ElseIf Target.Address = "$C$3" Then
    
28. If dic.exists(Range("b3").Value) Then k = dic(Range("b3").Value)
    
29. With Range("c3").Validation
    
30.         .Delete
    
31.         .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
    
32.         Operator:=xlBetween, Formula1:=k
    
33.     End With
    
34. End If
    
35. End Sub
    

复制代码

缔造者

参见附件：
此附件有错误
二级有效性下拉菜单—求助.rar (36.86 KB, 下载次数: 8)

2014-10-24 10:14 上传

点击文件名下载附件

zjdh

2楼  不先排序就建立名称，会遗漏项目的！
4楼  不适合项目较多的情况，选择上海后，点C3就出错啦！

hgdzhh

缔造者 发表于 2014-10-24 10:14
参见附件：

首先感谢，不过错误1004呀
主要用上海测试，其他的没增加，也会很多，超过字符限制。

zjdh

若不允许改变数据页排序，可用辅助列解决。
二级有效性下拉菜单(辅助列).rar (48.66 KB, 下载次数: 5)

2014-10-24 12:53 上传

点击文件名下载附件

缔造者

数据多时，前一个代码运行错误，现更正如下：
利用辅助列：

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.     If Target.Count > 1 Then Exit Sub
   
3.     If Target.Address <> "$B$3" And Target.Address <> "$C$3" Then Exit Sub
   
4.     Dim arr, k
   
5.     Dim i As Long
   
6.     Dim d As Object, dic As Object
   
7.     Set d = CreateObject("scripting.dictionary")
   
8.     Set dic = CreateObject("scripting.dictionary")
   
9.     arr = Worksheets("数据").Range("a3").CurrentRegion
   
10.     If Target.Address = "$B$3" Then
    
11.         Range("c3").Validation.Delete
    
12.         Range("c3").ClearContents
    
13.     For i = 3 To UBound(arr) - 1
    
14.         If Not d.exists(arr(i, 1)) Then
    
15.           d(arr(i, 1)) = ""
    
16.         End If
    
17.     Next i
    
18.         With Range("b3").Validation
    
19.             .Delete
    
20.             .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
    
21.                  Operator:=xlBetween, Formula1:=Join(d.keys, ",")
    
22.         End With
    
23.     ElseIf Target.Address = "$C$3" Then
    
24.     Range("iv1").Resize(65536).ClearContents
    
25.     For i = 3 To UBound(arr) - 1
    
26.     If arr(i, 1) = Range("b3") Then If Not dic.exists(arr(i, 2)) Then dic(arr(i, 2)) = ""
    
27.     Next i
    
28.       k = dic.keys
    
29.     Range("iv1").Resize(dic.Count) = Application.Transpose(k)
    
30. 
    
31.         With Range("c3").Validation
    
32.             .Delete
    
33.             .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
    
34.                  Operator:=xlBetween, Formula1:="=$iv$1:$iv$" & dic.Count 'cp"
    
35.         End With
    
36.     End If
    
37.     Set d = Nothing
    
38.     Set dic = Nothing
    
39. End Sub
    

复制代码

缔造者

利用辅助列：
二级有效性下拉菜单—求助-更正错误.rar (38.98 KB, 下载次数: 7)

2014-10-24 13:11 上传

点击文件名下载附件

缔造者

zjdh 发表于 2014-10-24 10:59
若不允许改变数据页排序，可用辅助列解决。

如果B列有重复项时，二级菜单中也出现该重复项。