如何实现二级菜单根据一级菜单内容自动显示

chengsijing · 发表于 2025-1-11 02:55

B2:C5000是内容，B列是班级名称，C列是学生姓名，如何在单元格下拉框选择了班级名称后，自动只显示该班级对应的学生（不显示其它班级的学生）

3190496160 · 发表于 2025-1-11 07:43

Private Sub Worksheet_SelectionChange(ByVal T As Range)
If T.Row = 1 And T.Column = 6 Then
Set d = CreateObject("scripting.dictionary")
r = Cells(Rows.Count, 2).End(xlUp).Row
arr = Range("b1:c" & r)
For i = 2 To UBound(arr)
      d(arr(i, 1)) = ""
Next i
T.Select
With Selection.Validation
      .Delete
      .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(d.keys, ",")
End With
d.RemoveAll
End If

End Sub
Private Sub Worksheet_Change(ByVal T As Range)
If T.Row = 1 And T.Column = 6 Then
If T.Count > 1 Then End
Set d = CreateObject("scripting.dictionary")
r = Cells(Rows.Count, 2).End(xlUp).Row
arr = Range("b1:c" & r)
For i = 2 To UBound(arr)
      If arr(i, 1) = T.Value Then
         d(arr(i, 2)) = ""
      End If
Next i
T.Offset(1).Select
With Selection.Validation
      .Delete
      .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(d.keys, ",")
End With
d.RemoveAll
End If
End Sub

3190496160 · 发表于 2025-1-11 07:44

二级菜单.rar (14.78 KB, 下载次数: 14)

quqiyuan · 发表于 2025-1-11 08:37

参与一下，仅供参考。。。
单元格f1/f2这两个单元格写的selectionchange事件，请留意

quqiyuan · 发表于 2025-1-11 08:38

代码如下。。。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$F$2" Or Target.Address = "$F$1" Then
      arr = Range([b1], Cells(Rows.Count, 3).End(3))
      Set d = CreateObject("scripting.dictionary")
      For i = 2 To UBound(arr)
         s = arr(i, 1)
         If s <> Empty And arr(i, 2) <> Empty Then
            If Not d.exists(s) Then
                  d(s) = arr(i, 2)
            Else
                  d(s) = d(s) & "," & arr(i, 2)
            End If
         End If
      Next
      If Target.Address = "$F$1" Then
         With Target.Validation
            .Delete
            kk = d.keys
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(d.keys, ",")
         End With
      ElseIf Target.Address = "$F$2" And d.exists([f1].Value) Then
         With Target.Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=d([f1].Value)
         End With
      End If
      Set d = Nothing
'       Beep
End If
End Sub

3190496160 · 发表于 2025-1-11 09:11

精简一下，用字典嵌套

二级菜单.rar (14.29 KB, 下载次数: 12)

3190496160 · 发表于 2025-1-11 09:12

Dim d As Object
Private Sub Worksheet_SelectionChange(ByVal T As Range)
If T.Row = 1 And T.Column = 6 Then
Set d = CreateObject("scripting.dictionary")
r = Cells(Rows.Count, 2).End(xlUp).Row
arr = Range("b1:c" & r)
For i = 2 To UBound(arr)
      If arr(i, 1) <> "" Then
         If Not d.exists(arr(i, 1)) Then Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
         d(arr(i, 1))(arr(i, 2)) = ""
      End If
Next i
T.Select
With Selection.Validation
      .Delete
      .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(d.keys, ",")
End With
End If
End Sub
Private Sub Worksheet_Change(ByVal T As Range)
If T.Row = 1 And T.Column = 6 Then
If T.Count > 1 Then End
T.Offset(1).Select
With Selection.Validation
      .Delete
      .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(d(T.Value).keys, ",")
End With
d.RemoveAll
End If
End Sub

chengsijing · 发表于 2025-1-11 15:26

3190496160 发表于 2025-1-11 09:12
Dim d As Object
Private Sub Worksheet_SelectionChange(ByVal T As Range)
If T.Row = 1 And T.Column ...

不好意思，我以为用类似上面函数就能处理了。用VBA代码的话不知道实时判断单元格变化是否消耗资源。参照你的代码，我修改的VBA代码如下：
一个是字典的，一个只用字符的。不知道哪个效率最高，有请高手点评一下。

Private Sub Worksheet_Change(ByVal T As Range)
If Not Intersect(T, Me.Range("F1")) Is Nothing Then
Dim d As Object, d2 As Object, bj As String
bj = T.Value2
If Len(bj) > 0 Then '防止一级菜单值为空
Cells(2, 6).Value2 = "" '清空二级菜单原有的值
Set d = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
d(bj) = 1 '使用字典来判断
r = Cells(Rows.Count, 2).End(xlUp).Row
arr = Range("b1:c" & r)
For i = 2 To UBound(arr)
If d.exists(arr(i, 1)) Then d2(arr(i, 2)) = i 'If arr(i, 1) = bj Then 不知道哪个效率更快
Next i
Cells(2, 6).Select
With Selection.Validation
.Delete
'防止找不到对应的二级菜单值
If d2.Count > 0 Then .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(d2.keys, ",")
End With
Set d = Nothing
Set d2 = Nothing
End If
End If
End Sub
Private Sub Worksheet_Change(ByVal T As Range)
If Not Intersect(T, Me.Range("F1")) Is Nothing Then
Dim bj As String, cd2 As String
bj = T.Value2
If Len(bj) > 0 Then '防止一级菜单值为空
Cells(2, 6).Value2 = "" '清空二级菜单原有的值
r = Cells(Rows.Count, 2).End(xlUp).Row
arr = Range("b1:c" & r)
For i = 2 To UBound(arr)
If arr(i, 1) = bj Then
If cd2 <> "" Then
cd2 = cd2 & "," & arr(i, 2)
Else
cd2 = arr(i, 2)
End If
End If
Next i
Cells(2, 6).Select
With Selection.Validation
.Delete
'防止找不到对应的二级菜单值
If cd2 <> "" Then .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=cd2
End With
Set d = Nothing
Set d2 = Nothing
End If
End If
End Sub

复制代码

3190496160 · 发表于 2025-1-12 12:25

chengsijing 发表于 2025-1-11 15:26
不好意思，我以为用类似上面函数就能处理了。用VBA代码的话不知道实时判断单元格变化是否消耗资源。 ...

想多了吧？？呵呵

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

[求助] 如何实现二级菜单根据一级菜单内容自动显示

评分

评分

评分

评分