Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2994|回复: 11

[已解决]多级菜单的VBA代码

[复制链接]
发表于 2016-5-2 17:39 | 显示全部楼层 |阅读模式
选择A单元格的数据到单元格内,再点击B单元格就只显示与A单元格的子项目,以此类推的VBA代码
最佳答案
2016-5-3 13:44
  1. Dim d, d1
  2. Sub init()     '初始化
  3.     Set d = CreateObject("scripting.dictionary")
  4.     Set d1 = CreateObject("scripting.dictionary")
  5.     With Sheets(2)
  6.         arr = .Range("a3:d" & [a65536].End(3).Row)
  7.         For i = 1 To UBound(arr)
  8.             qy = arr(i, 4) '区域
  9.             sf = arr(i, 2) '省份
  10.             If Len(qy) > 0 Then
  11.                 If InStr(d(qy), sf) = 0 Then d(qy) = d(qy) & "," & sf '区域为key,省份为item,item去重
  12.                 If InStr(d1(sf), arr(i, 3)) = 0 Then d1(sf) = d1(sf) & "," & arr(i, 3)   '省份key,城市为item
  13.             End If
  14.         Next
  15.     End With
  16. End Sub

  17. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  18.     If Target.Count > 1 Then Exit Sub
  19.     c = Target.Column: r = Target.Row
  20.     If c > 3 Or r < 5 Then Exit Sub
  21.     Call init        '初始化
  22.     If c = 3 Then
  23.         xStr = Join(d.keys, ",")
  24.     ElseIf c = 1 Then
  25.         xStr = Mid(d(Cells(r, 3).Value), 2)
  26.     ElseIf c = 2 Then
  27.         xStr = Mid(d1(Cells(r, 1).Value), 2)
  28.     End If
  29.     If Len(xStr) Then
  30.         With Target.Validation
  31.             .Delete
  32.             .Add xlValidateList, , , xStr
  33.         End With
  34.     End If
  35. End Sub
复制代码

四级菜单VBA代码.rar

18.88 KB, 下载次数: 24

发表于 2016-5-2 22:48 | 显示全部楼层
回复

使用道具 举报

 楼主| 发表于 2016-5-3 08:23 | 显示全部楼层
cabcd1 发表于 2016-5-2 22:48
一定要用vba吗

因为表内的4个级别的名称随时都会新增,还有其他的办法吗?
回复

使用道具 举报

发表于 2016-5-3 09:29 | 显示全部楼层
这个做过多次了,自己网上查查吧。思路是用2个字典,d1的key对应一级菜单,d1的item对应二级菜单;
以一级+二级菜单为key,d2的item对应三级菜单。
回复

使用道具 举报

 楼主| 发表于 2016-5-3 09:51 | 显示全部楼层
grf1973 发表于 2016-5-3 09:29
这个做过多次了,自己网上查查吧。思路是用2个字典,d1的key对应一级菜单,d1的item对应二级菜单;
以一级 ...

搜索了没有找到合适的,能否提供下这方面的信息
回复

使用道具 举报

发表于 2016-5-3 10:26 | 显示全部楼层
  1. Dim d, d1
  2. Sub init()     '初始化
  3.     Set d = CreateObject("scripting.dictionary")
  4.     Set d1 = CreateObject("scripting.dictionary")
  5.     With Sheets(2)
  6.         arr = .Range("a4:j12")
  7.         For j = 1 To UBound(arr, 2)
  8.             For i = 2 To UBound(arr)
  9.                 If Len(arr(i, j)) > 0 Then d(arr(1, j)) = d(arr(1, j)) & "," & arr(i, j)
  10.             Next
  11.         Next
  12.         
  13.         arr = .Range("a17:ay27")
  14.         For j = 1 To UBound(arr, 2)
  15.             For i = 2 To UBound(arr)
  16.                 If Len(arr(i, j)) > 0 Then d1(arr(1, j)) = d1(arr(1, j)) & "," & arr(i, j)
  17.             Next
  18.         Next
  19.     End With
  20. End Sub

  21. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  22.     If Target.Count > 1 Then Exit Sub
  23.     c = Target.Column: r = Target.Row
  24.     If c > 3 And r < 5 Then Exit Sub
  25.     Call init        '初始化
  26.     If c = 1 Then
  27.         xStr = Join(d.keys, ",")
  28.     Else
  29.         x = Target.Offset(, -1)
  30.         If c = 2 Then
  31.             xStr = Mid(d(x), 2)
  32.         ElseIf c = 3 Then
  33.             xStr = Mid(d1(x), 2)
  34.         End If
  35.     End If
  36.     If Len(xStr) Then
  37.         With Target.Validation
  38.             .Delete
  39.             .Add xlValidateList, , , xStr
  40.         End With
  41.     End If
  42. End Sub
复制代码

四级菜单VBA代码.rar

38.12 KB, 下载次数: 47

回复

使用道具 举报

 楼主| 发表于 2016-5-3 12:06 | 显示全部楼层
本帖最后由 安全网 于 2016-5-3 12:10 编辑
grf1973 发表于 2016-5-3 10:26

如果数据表名称是这样的怎么修改代码

四级菜单VBA代码.rar

28.56 KB, 下载次数: 6

回复

使用道具 举报

发表于 2016-5-3 13:44 | 显示全部楼层    本楼为最佳答案   
  1. Dim d, d1
  2. Sub init()     '初始化
  3.     Set d = CreateObject("scripting.dictionary")
  4.     Set d1 = CreateObject("scripting.dictionary")
  5.     With Sheets(2)
  6.         arr = .Range("a3:d" & [a65536].End(3).Row)
  7.         For i = 1 To UBound(arr)
  8.             qy = arr(i, 4) '区域
  9.             sf = arr(i, 2) '省份
  10.             If Len(qy) > 0 Then
  11.                 If InStr(d(qy), sf) = 0 Then d(qy) = d(qy) & "," & sf '区域为key,省份为item,item去重
  12.                 If InStr(d1(sf), arr(i, 3)) = 0 Then d1(sf) = d1(sf) & "," & arr(i, 3)   '省份key,城市为item
  13.             End If
  14.         Next
  15.     End With
  16. End Sub

  17. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  18.     If Target.Count > 1 Then Exit Sub
  19.     c = Target.Column: r = Target.Row
  20.     If c > 3 Or r < 5 Then Exit Sub
  21.     Call init        '初始化
  22.     If c = 3 Then
  23.         xStr = Join(d.keys, ",")
  24.     ElseIf c = 1 Then
  25.         xStr = Mid(d(Cells(r, 3).Value), 2)
  26.     ElseIf c = 2 Then
  27.         xStr = Mid(d1(Cells(r, 1).Value), 2)
  28.     End If
  29.     If Len(xStr) Then
  30.         With Target.Validation
  31.             .Delete
  32.             .Add xlValidateList, , , xStr
  33.         End With
  34.     End If
  35. End Sub
复制代码

四级菜单VBA代码.rar

39.44 KB, 下载次数: 35

回复

使用道具 举报

 楼主| 发表于 2016-5-3 14:23 | 显示全部楼层
grf1973 发表于 2016-5-3 13:44

我用了好像不能从A-B-C列依次使用
回复

使用道具 举报

发表于 2016-5-3 14:38 | 显示全部楼层
按C-A-B次序,区域最大,省次之,城市再次之
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 21:26 , Processed in 0.930449 second(s), 9 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表