[已解决]指定数据源区域二级下拉列表

lidayu

垦请老师赐教用VBA如何实现二级下拉列表，详情附件
指定数据源区域二级下拉列表.rar (9.03 KB, 下载次数: 12)

2016-2-22 11:30 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

scl5801

2016-2-22 13:42

lidayu 发表于 2016-2-22 12:05
您好，谢谢您的帮助，我想的是用VBA。

看看对不

跳转到最佳答案楼层

sry660

详见附件

lidayu

sry660 发表于 2016-2-22 11:59
详见附件

您好，谢谢您的帮助，我想的是用VBA。

scl5801

lidayu 发表于 2016-2-22 12:05
您好，谢谢您的帮助，我想的是用VBA。

看看对不

scl5801

不好意思，文件格式错了
另传

scl5801

把你的解决方案分享一下行吗？

lidayu

scl5801 发表于 2016-2-22 14:33
把你的解决方案分享一下行吗？

你好，二级不要再有一级的内容出现就可以了，谢谢！

scl5801

lidayu 发表于 2016-2-22 14:45
你好，二级不要再有一级的内容出现就可以了，谢谢！

我认为你已有解决方法，想学习下。
这个不显第一个
Private Sub Worksheet_SelectionChange(ByVal Target As Range) '单击触发事件
   With Application
    .ScreenUpdating = False
     Cells.Validation.Delete
     On Error Resume Next
     If Target.Column = 4 Then
        myr = Sheet1.UsedRange.Columns.Count
        arr = Sheet1.Range("a2").Resize(, myr)
        For i = 2 To myr
            aa = aa & arr(1, i) & ","
        Next i
        With Target.Validation
           .Delete
           .Add Type:=xlValidateList, Formula1:=aa
           .ShowError = False
        End With
        aa = ""
     End If
     If Target.Column = 5 Then
        If ActiveCell.Offset(, -1) = "" Then Exit Sub
        arr = Sheet1.UsedRange
        For i = 2 To UBound(arr, 2)
           If arr(2, i) = ActiveCell.Offset(, -1) Then
              j = i
           End If
        Next i
        y = UCase(ActiveCell)
        For i = 3 To UBound(arr, 1)
           If arr(i, j) Like "*" & y & "*" Then
              aa = aa & arr(i, j) & ","
           End If
        Next i
        With Target.Validation
           .Delete
               .Add Type:=xlValidateList, Formula1:=aa
           .ShowError = False
        End With
        aa = ""
        y = ""
     End If
    .ScreenUpdating = True
  End With
End Sub

lidayu

scl5801 发表于 2016-2-22 14:33
把你的解决方案分享一下行吗？

您好，我的解决方案如下：

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2. If Target.Columns.Count > 1 Or Target.Rows.Count > 1 Then Exit Sub
   
3. If Target.Column < 4 Or Target.Column > 5 Then Exit Sub
   
4. arr = Sheets("数据源").[a1:m7]
   
5. If Target.Column = 4 Then
   
6.     r = Application.Transpose(Sheets("数据源").[b2].Resize(1, UBound(arr, 2) - 1))
   
7.     ElseIf Target.Column = 5 Then
   
8.     If Target.Offset(0, -1) <> "" Then
   
9.         Set Rng = Sheets("数据源").Rows("2:2").Find(Target.Offset(0, -1))
   
10.         r = Rng.Offset(1, 0).Resize(UBound(arr) - 2, 1)
    
11.         Else: Exit Sub
    
12.     End If
    
13. End If
    
14. For i = 1 To UBound(r)
    
15.     If r(i, 1) <> "" Then s = s & "," & r(i, 1)
    
16. Next
    
17. s = Mid(s, 2)
    
18. With Target.Validation
    
19.     .Delete
    
20.     .Add xlValidateList, , , s
    
21. End With
    
22. End Sub

复制代码

lidayu

scl5801 发表于 2016-2-22 15:01
我认为你已有解决方法，想学习下。
这个不显第一个
Private Sub Worksheet_SelectionChange(ByVal Targ ...

您好，您的代码没有去重复及B2：M2区域处如果有数据也会被当成下拉，我要的是指定区域。不够还要谢谢您的赐教！