发布时间 : 星期日 文章Excel VBA_澶氱骇鍔ㄦ�佹暟鎹湁鏁堟�ц缃疄渚嬮泦閿?- 鐧惧害鏂囧簱更新完毕开始阅读
Case \组 织\
For i = 0 To UBound(k(1)) aa = aa & k(1)(i) & \ Next
With Target.Validation .Delete
.Add 3, 1, 1, aa End With Case \公 司\
If Target.Row = 13 Then With Target.Validation .Delete
.Add 3, 1, 1, Join(k(2), \ End With Else
bm = d1(1)([d8].Value) For i = 0 To UBound(k(2))
If Left(k(2)(i), 4) = bm Then aa = aa & k(2)(i) & \ Next
With Target.Validation .Delete
.Add 3, 1, 1, aa End With End If
Case \上级部门\
If Target.Row = 13 Then bm = d1(2)([d13].Value) For i = 0 To UBound(k(3))
If Left(k(3)(i), 6) = bm Then aa = aa & k(3)(i) & \ Next
With Target.Validation .Delete
If aa <> \ End With Else
bm = d1(2)([g8].Value) For i = 0 To UBound(k(3))
If Left(k(3)(i), 6) = bm Then aa = aa & k(3)(i) & \ Next
With Target.Validation .Delete
If aa <> \ End With End If
Case \部 门\
If Target.Row = 13 Then bm = d1(3)([g13].Value) For i = 0 To UBound(k(4))
If Left(k(4)(i), 8) = bm Then aa = aa & k(4)(i) & \ Next
With Target.Validation .Delete
If aa <> \ End With Else
bm = d1(3)([j8].Value) For i = 0 To UBound(k(4))
If Left(k(4)(i), 8) = bm Then aa = aa & k(4)(i) & \ Next
With Target.Validation .Delete
If aa <> \ End With End If End Select End Sub
28，3级动态数据有效性多选（列表框）
‘2014-8-4
‘http://club.excelhome.net/forum.php?mod=viewthread&tid=1142144&page=1#pid7787045 Dim d, Arr
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Dim i&, Myr&, col% Myr = ActiveCell.Row
col = ActiveCell.Column + 1
For i = 0 To ListBox1.ListCount - 1 If ListBox1.Selected(i) Then
Cells(Myr, col) = Cells(Myr, col) & ListBox1.List(i) & vbCrLf End If Next
ListBox1.Visible = False End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Column > 7 Or Target.Column < 6 Or Target.Row < 3 Then Exit Sub If Target = \Dim d2, c%, i&
Set d2 = CreateObject(\Call yy
If Target.Column = 6 Then c = d(Target.Value)
For i = 2 To UBound(Arr)
If Arr(i, c) = \ d2(Arr(i, c)) = \ Next
With Target.Offset(0, 1).Validation .Delete
.Add 3, 1, 1, Join(d2.keys, \ End With
Target.Offset(0, 1).Resize(1, 2) = \Else
c = d(Target.Value): d2.RemoveAll For i = 2 To UBound(Arr)
If Arr(i, c) = \ d2(Arr(i, c)) = \ Next
With Me.ListBox1 .Visible = True .List = d2.keys
.Top = Target.Offset(1, 0).Top .Left = Target.Offset(0, 1).Left End With
Target.Offset(0, 1) = \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 <> 6 Or Target.Row < 3 Then Me.ListBox1.Visible = False: Exit Sub Dim i&, d1
Target.Resize(1, 3) = \
Set d1 = CreateObject(\Call yy
For i = 2 To UBound(Arr)
If Arr(i, 1) = \ d1(Arr(i, 1)) = \ Next
With Target.Validation .Delete
.Add 3, 1, 1, Join(d1.keys, \ End With End Sub Sub yy()
Set d = CreateObject(\Arr = Sheet1.[a1].CurrentRegion For i = 1 To UBound(Arr, 2) d(Arr(1, i)) = i Next
End Sub
29，多级联动及多项选择（列表框+SQL）
‘by:百度不到去谷歌 ‘2014-8-6
‘http://club.excelhome.net/forum.php?mod=viewthread&tid=1143298&page=1#pid7791103 Function SqlToArr(sql$) '查询结果到数组
Dim cnn As Object 'New ADODB.Connection Dim rs As Object, arr 'New ADODB.Recordset Set cnn = CreateObject(\
cnn.Open \=\
ThisWorkbook.FullName 'ThisWorkbook.Path & \数据源.xls\本表文件名就是本表,其他表就用其他文件名或完整路径 On Error Resume Next Set rs = cnn.Execute(sql)
SqlToArr = Application.Transpose(rs.GetRows) '转置为excle格式的行列 End Function
Private Sub ListBox1_Change() Call 智能查询 End Sub
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