怎么用VBA作下拉选项

深秋红叶2019

问题如下图片红色框描述，谢谢

liulang0808

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.     If Target.Count <> 1 Then Exit Sub
   
3.     If Target.Row <= 3 Then Exit Sub
   
4.     If Target.Column = 2 Then
   
5.         arr = Sheets("物品库存统计").UsedRange
   
6.         Set d = CreateObject("scripting.dictionary")
   
7.         For j = 5 To UBound(arr)
   
8.             If Len(arr(j, 1)) > 0 Then d(arr(j, 1)) = j
   
9.         Next j
   
10.         With Target.Validation
    
11.             .Delete
    
12.             .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
    
13.             xlBetween, Formula1:=Join(d.keys, ",")
    
14.             .IgnoreBlank = True
    
15.             .InCellDropdown = True
    
16.             .InputTitle = ""
    
17.             .ErrorTitle = ""
    
18.             .InputMessage = ""
    
19.             .ErrorMessage = ""
    
20.             .IMEMode = xlIMEModeNoControl
    
21.             .ShowInput = True
    
22.             .ShowError = True
    
23.         End With
    
24.     Else
    
25.         If Target.Column = 9 Then
    
26.             arr = Sheets("物品库存统计").UsedRange
    
27.             Set d = CreateObject("scripting.dictionary")
    
28.             For j = 5 To UBound(arr)
    
29.                 If Len(arr(j, 9)) > 0 Then d(arr(j, 9)) = j
    
30.             Next j
    
31.             With Target.Validation
    
32.                 .Delete
    
33.                 .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
    
34.                 xlBetween, Formula1:=Join(d.keys, ",")
    
35.                 .IgnoreBlank = True
    
36.                 .InCellDropdown = True
    
37.                 .InputTitle = ""
    
38.                 .ErrorTitle = ""
    
39.                 .InputMessage = ""
    
40.                 .ErrorMessage = ""
    
41.                 .IMEMode = xlIMEModeNoControl
    
42.                 .ShowInput = True
    
43.                 .ShowError = True
    
44.             End With
    
45.         End If
    
46.     End If
    
47. End Sub

复制代码

liulang0808

附件事件供参考，楼主这是要做一个系统吗？

网海遨游

Sub 下拉菜单()
Dim sht As Worksheet, arr, d As Object, i%, s, r
Set sht = Sheets("物品库存统计")
r = sht.Cells(Rows.Count, 1).End(3).Row
arr = sht.Range("a4:a" & r)
Set d = CreateObject("scripting.dictionary")
     For i = 2 To UBound(arr)
          s = arr(i, 1)
          If Not d.exists(s) Then
               d(s) = ""
          End If
     Next i
With Sheets("物品出入库记录").Range("b4:b10000").Validation '在区域制作筛选下拉菜单
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(d.keys, ",")
    End With
'----------------------------以下是I列-------------------
    Dim r1
    Erase arr: d.RemoveAll
    r1 = sht.Cells(Rows.Count, 9).End(3).Row
    arr = sht.Range("i4:i" & r1)
     For i = 2 To UBound(arr)
          s = arr(i, 1)
          If Not d.exists(s) Then
               d(s) = ""
          End If
     Next i
With Sheets("物品出入库记录").Range("i4:i10000").Validation '在区域制作筛选下拉菜单
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(d.keys, ",")
    End With
End Sub

深秋红叶2019

liulang0808 发表于 2020-1-30 14:54
附件事件供参考，楼主这是要做一个系统吗？

谢谢老师，差不多是吧，之前用函数太卡了，所以在这个精英聚集的论坛里求助，老师在帮个忙可以吗，如果老师有空这个帖子帮我写一下代码，问题也是图片上红色框的问题，http://club.excelhome.net/forum.php?mod=viewthread&tid=1519411&mobile=2

深秋红叶2019

网海遨游 发表于 2020-1-30 15:01
Sub 下拉菜单()
Dim sht As Worksheet, arr, d As Object, i%, s, r
Set sht = Sheets("物品库存统计")

谢谢老师，回去我试一下

YZC51

请参考
蓝泰学校-学员登记库存(正式).zip (54.38 KB, 下载次数: 12)

2020-1-30 15:21 上传

点击文件名下载附件

YZC51

请参考7楼附件

网海遨游

工作表事件

Private Sub Worksheet_SelectionChange(ByVal T As Range) '代码要放在工作表("物品出入库记录")中
   '-----------------------B列----------------------
   If T.Row > 1 And T.Column = 2 Then
        Dim sht As Worksheet, arr, d As Object, i%, s, r, r1, s1
         Set sht = Sheets("物品库存统计")
         r = sht.Cells(Rows.Count, 1).End(3).Row
         arr = sht.Range("a4:a" & r)
         Set d = CreateObject("scripting.dictionary")
         For i = 2 To UBound(arr)
               s = arr(i, 1)
               If Not d.exists(s) Then
                    d(s) = ""
               End If
          Next i
          With Sheets("物品出入库记录").Cells(T.Row, T.Column).Validation '在区域制作筛选下拉菜单
             .Delete
             .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(d.keys, ",")
         End With
         Erase arr: Set d = Nothing
    End If
  '-----------------------I列----------------------
      
  If T.Row > 3 And T.Column = 9 Then
      Set d = CreateObject("scripting.dictionary")
      Set sht = Sheets("物品库存统计")
      r1 = sht.Cells(Rows.Count, 9).End(3).Row
      arr = sht.Range("i4:i" & r1)
       For i = 2 To UBound(arr)
            s1 = arr(i, 1)
            If Not d.exists(s1) Then
                 d(s1) = ""
            End If
       Next i
      With Sheets("物品出入库记录").Cells(T.Row, T.Column).Validation '在区域制作筛选下拉菜单
          .Delete
          .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(d.keys, ",")
      End With
      Erase arr: Set d = Nothing
    End If
End Sub

深秋红叶2019

liulang0808 发表于 2020-1-30 14:54
附件事件供参考，楼主这是要做一个系统吗？

老师，如果单元格没有匹配的条件，单价和单位都不要代码怎么改呢，谢谢老师