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)