发布时间 : 星期日 文章Excel VBA_多级动态数据有效性设置实例集锦更新完毕开始阅读
If .Selected(i) Then s = s & \ Next
.Visible = False End With
If Len(s) Then ActiveCell = Mid(s, 2) End If End Sub
Private Sub ListBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim i&, s$
If KeyCode = 13 Then With ListBox2
For i = 0 To .ListCount - 1
If .Selected(i) Then s = s & \ Next
.Visible = False End With
If Len(s) Then ActiveCell = Mid(s, 2) End If End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Count > 1 Then Exit Sub
If Target.Row >= 3 And Target.Column = 5 Then With ListBox1
.Top = Target.Top
.Left = Target.Offset(, 1).Left .Height = 194.25 .Width = 150
.List = SqlToArr(\省 from [数据源$] where 省<>''\查询省 .Visible = True End With
ElseIf Target.Row >= 3 And Target.Column = 6 Then With ListBox2
.Top = Target.Top
.Left = Target.Offset(, 1).Left .Height = 194.25 .Width = 150 Call 智能查询 .Visible = True End With Else
ListBox1.Visible = False
ListBox2.Visible = False End If End Sub
Public Sub 智能查询() Dim s, i
With ListBox1
For i = 0 To .ListCount - 1
If .Selected(i) Then s = s & \ Next
s = \ End With
On Error Resume Next
ListBox2.List = SqlToArr(\ 市 from [数据源$] where 省 in \ '查询对应市 If Err.Number <> 0 Then ListBox2.List = SqlToArr(\ 市 from [数据源$] where 省 <>'' \End Sub
30，多级联动及多项选择（列表框+字典）
‘2014-8-6
‘http://club.excelhome.net/forum.php?mod=viewthread&tid=1143298&page=1#pid7791103 Dim d, Arr, r&, Arr1(), gs, d1
Private Sub ListBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim i&, s$
If KeyCode = 13 Then With ListBox1
For i = 0 To .ListCount - 1
If .Selected(i) Then s = s & \ Next
.Visible = False End With
If Len(s) Then ActiveCell = Mid(s, 2): ActiveCell.Offset(0, 1).Select End If End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Count > 1 Then Me.ListBox1.Visible = False: Exit Sub
If Target.Column < 10 Or Target.Column > 13 Or Target.Row < 3 Then Me.ListBox1.Visible = False: Exit Sub Dim i&, j&, k
If Target.Column = 10 Then
Arr = Sheet1.[a2].CurrentRegion
Set d = CreateObject(\ Target.Resize(1, 4) = \ For i = 2 To UBound(Arr) If Arr(i, 1) <> \ r = r + 1
ReDim Preserve Arr1(1 To r) Arr1(r) = i d(Arr(i, 1)) = r End If Next
k = d.keys
ElseIf Target.Column = 11 Then
Arr = Sheet1.[a2].CurrentRegion
Set d = CreateObject(\ Target.Resize(1, 3) = \ For i = 2 To UBound(Arr) If Arr(i, 1) <> \ r = r + 1
ReDim Preserve Arr1(1 To r) Arr1(r) = i d(Arr(i, 1)) = r End If Next
gs = Target.Offset(0, -1).Value Call yy(gs) k = d1.keys
ElseIf Target.Column = 12 Then Target.Resize(1, 2) = \
gs = Target.Offset(0, -2).Value: r = 0 Arr = Sheet1.[d2].CurrentRegion
Set d = CreateObject(\ For i = 2 To UBound(Arr) If Arr(i, 1) <> \ r = r + 1
ReDim Preserve Arr1(1 To r) Arr1(r) = i d(Arr(i, 1)) = r End If Next
Call yy(gs) k = d1.keys
ElseIf Target.Column = 13 Then
gs = Target.Offset(0, -1).Value: r = 0 Arr = Sheet1.[g2].CurrentRegion
Set d = CreateObject(\ For i = 2 To UBound(Arr) If Arr(i, 1) <> \ r = r + 1
ReDim Preserve Arr1(1 To r) Arr1(r) = i
If InStr(Arr(i, 1), \，\ aa = Split(Arr(i, 1), \，\ For j = 0 To UBound(aa)
b = Left(aa(j), Len(aa(j)) - 1) d(b) = r Next Else
b = Left(Arr(i, 1), Len(Arr(i, 1)) - 1) d(b) = r End If End If Next
Call yy1(gs) k = d1.keys Else
Exit Sub End If
With Me.ListBox1 .Clear
.Visible = True .List = k
.Top = Target.Offset(1, 0).Top .Left = Target.Offset(0, 1).Left End With End Sub Sub yy(gs)
Dim aa, i&, j&, ks, js, jj&
Set d1 = CreateObject(\ If InStr(gs, \ aa = Split(gs, \
For j = 0 To UBound(aa) i = d(aa(j)) If i <> r Then
js = Arr1(i + 1) - 1 Else
js = UBound(Arr)