发布时间 : 2024/6/1 12:41:12 星期六 文章Excel VBA_澶氱骇鍔ㄦ�佹暟鎹湁鏁堟�ц缃疄渚嬮泦閿?- 鐧惧害鏂囧簱更新完毕开始阅读bf4d9a1651e79b89680226cf

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