Ecel VBA排课表显示实例集锦.docxVIP

PAGE PAGE 10 / 42 1，排课表显示（字典套字典） ‘http: 1.html ‘求助课表中如何自动合并 xx.xls ‘2014-4-20。 Sub lqxs() Dim Arr, i, j, b, xq$, x$, y$, aa, xinq, col Dim d, k, t, kk, tt, jj, q, c, m, m1, bj$, n Application.ScreenUpdating = False Set d = CreateObject(Scripting.Dictionary) xinq = Array(星期一, 星期二, 星期三, 星期四, 星期五) col = Array( 1、2, 3、4, 5、6, 7、8, 9、10) Sheet 3.Activate [b4:b500].ClearContents [d4:ab500].ClearContents Arr = Sheet 1.[a1].CurrentRegion For j = 3 To UBound(Arr, 2) Step 5 xq = Arr(3, j)星期 For b = j To j + 4 For i = 7 To UBound(Arr) - 1 Step 3 x = Arr(i, b) If x Then y = Arr(i - 1, b) , Arr(i + 1, b)课程和场地 If d.exists(x) = False Then Set d(x) = CreateObject(Scripting.Dictionary)d(x)(y) = d(x)(y) Arr(i - 1, 1) , xq Arr(5, b) |End If Next Next Next k = d.keys: t = d.items: n = 1 For i = 0 To UBound(k) n = n + 3 Cells(n, 2) = k(i) kk = t(i).keys: tt = t(i).items For j = 0 To UBound(tt) kc = Split(kk(j), ,) tt(j) = Left(tt(j), Len(tt(j)) - 1) If InStr(tt(j), |) Then aa = Split(tt(j), |) For jj = 0 To UBound(aa) a = Split(aa(jj), ,) bj = a (0) q = Split(a (1)) (0) c = Split(a (1)) (1) m = Application.Match(q, xinq, 0) - 1 m1 = Application.Match(c, col, 0) - 1 cc = 5 * m + 4 + m1 If Cells(n, cc) = Then Cells(n, cc) = bj Cells(n + 1, cc) = kc (0) Cells(n + 2, cc) = kc (1) Else Cells(n, cc) = Cells(n, cc) vbCrLf bj End If Next Else a = Split(tt(j), ,) bj = a (0) q = Split(a (1)) (0) c = Split(a (1)) (1) m = Application.Match(q, xinq, 0) - 1 m1 = Application.Match(c, col, 0) - 1 cc = 5 * m + 4 + m1 Cells(n, cc) = bj Cells(n + 1, cc) = kc (0) Cells(n + 2, cc) = kc (1) End If Next Next Application.ScreenUpdating = True End Sub Private Sub Worksheet_Activate() Dim Arr, i, d Set d = CreateObject(Scripting.Dictionary) Arr = Sheet 4.[a1].CurrentRegion For i = 2 To UBound(Arr) d(Arr(i, 2)) = Next With [j2].Validation .Delete .Add 3, 1, 1, Join(d.keys, ,) End With End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address $J$2 Then Exit Sub If Target