vba多级下拉菜单

wxjwxf · 发表于 2016-5-28 21:16

求助.zip (33 KB, 下载次数: 43)

hzruziniu · 发表于 2016-5-28 23:23

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 And Target.Row = 3 Then
产品名称下拉
End If
If Target.Column = 3 And Target.Row = 6 Then
规格下拉
End If
End Sub
Private Sub Worksheet_Activate()
收货单位下拉
End Sub
Sub 收货单位下拉()
Dim arr, d As Object
Set d = CreateObject("scripting.dictionary")
On Error Resume Next
arr = Sheet3.Range("B2:B" & Sheet3.Range("B65536").End(xlUp).Row) '.CurrentRegion
For i = 1 To UBound(arr)
d(arr(i, 1)) = ""
Next
With Range("c3").Validation
.Delete
.Add 3, 1, 1, Join(d.keys, ",")
End With
Set d = Nothing
End Sub
Sub 产品名称下拉()
Dim brr, d1 As Object
Set d1 = CreateObject("scripting.dictionary")
On Error Resume Next
brr = Sheet3.Range("B2:D" & Sheet3.Range("B65536").End(xlUp).Row) '.CurrentRegion
For i = 1 To UBound(brr)
If brr(i, 1) = Range("C3") Then
d1(brr(i, 2)) = ""
End If
Next
With Range("c6").Validation
.Delete
.Add 3, 1, 1, Join(d1.keys, ",")
End With
Set d1 = Nothing
End Sub
Sub 规格下拉()
Dim crr, d2 As Object
Set d2 = CreateObject("scripting.dictionary")
On Error Resume Next
crr = Sheet3.Range("B2:D" & Sheet3.Range("B65536").End(xlUp).Row) '.CurrentRegion
For i = 1 To UBound(crr)
If crr(i, 1) = Range("C3") And crr(i, 2) = Range("C6") Then
d2(crr(i, 3)) = ""
End If
Next
With Range("c8:c27").Validation
.Delete
.Add 3, 1, 1, Join(d2.keys, ",")
End With
Set d2 = Nothing
End Sub

复制代码

hzruziniu · 发表于 2016-5-28 23:25

求助.rar (27.27 KB, 下载次数: 325)

wxjwxf · 发表于 2016-5-29 07:12

hzruziniu 发表于 2016-5-28 23:25

即可手工录入也可选择下拉

		自动登录	找回密码
密码			免费注册

[求助] vba多级下拉菜单