ExcelVBA排课表显示实例集锦

1、1，排课表显示（字典套字典）http:1.html求助课表中如何自动合并 xx.xls201-4-20。Sub lqxs()Dim Arr, i&, j&, b&, xq$, x$, y$, aa, xinq, colDim d, k, t, kk, tt, jj&, q, c, m&, m1&, bj$, n&Application.ScreenUpdating = FalseSet d = CreateObject("Scripting.Dictionary")xinq = Arrays星期一",&quo

2、t;星期二","星期三","星期四","星期五")col = Array("1、2",37 / 423、4", "5、 6", "7、8",9、10")Sheet3.Activateb4:b500.ClearContentsd4:ab500.ClearContentsArr = Sheet1.a1.CurrentRegionFor j = 3 To UBound(Arr, 2) Step 5xq = Arr(3, j)'星期For b =

3、 j To j + 4For i = 7 To UBound(Arr) - 1 Step 3x = Arr(i, b)If x <> "" Theny = 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 &

4、amp; " " & Arr(5, b) & "|"End IfNextNextNext k = d.keys: t = d.items:n = 1For i = 0 To UBound(k)n = n + 3Cells(n, 2) = k(i)kk = t(i).keys:tt = t(i).itemsFor j = 0 To UBound(tt) kc = Split(kk(j), ",") tt(j) = Left(tt(j), Len(tt(j) - 1) If InStr(tt(j), "|&quo

5、t;) 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) = bjCells(

6、n + 1, cc) = kc(0)Cells(n + 2, cc) = kc(1)ElseCells(n, cc) = Cells(n, cc) & vbCrLf & bjEnd IfNextElsea = 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 + m1Cells(n, cc) = bjCells

7、(n + 1, cc) = kc(0)Cells(n + 2, cc) = kc(1)End IfNextNextApplication.ScreenUpdating = TrueEnd SubPrivate Sub Worksheet_Activate()Dim Arr, i&, dSet d = CreateObject("Scripting.Dictionary")Arr = Sheet4. a1.CurrentRegionFor i = 2 To UBound(Arr)d(Arr(i, 2) = ""NextWith j2.Validat

8、ion.Delete.Add 3, 1, 1, Join(d.keys, ",")End WithEnd SubPrivate Sub Worksheet_Change(ByVal Target As Range)If Target.Address <> "$J$2" Then Exit SubIf Target = "" Then Exit SubApplication.ScreenUpdating = FalseSet d = CreateObject("Scripting.Dictionary")

9、xinq = Arrays星期一","星期二","星期三","星期四","星期五")col = Array("1、2",3、 4", "5、6", "7、8",9、10")c4:q13.ClearContentsArr = Sheet1.a1.CurrentRegionFor j = 3 To UBound(Arr, 2) Step 5xq = Arr(3, j)星 期For b = j To j + 4For i = 7 T

10、o UBound(Arr) - 1 Step 3x = Arr(i, b)If x = Target.Value Theny = 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(

11、5, b) & "|"End IfNextNextNextk = d.keys:t = d.items:n = 3For i = 0 To UBound(k)kk = t(i).keys:tt = t(i).itemsFor j = 0 To UBound(tt)kc = Split(kk(j), ",")tt(j) = Left(tt(j), Len(tt(j) - 1)If InStr(tt(j), "|") Thenaa = Split(tt(j), "|")For jj = 0 To UBound(

12、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 If Cells(2 * m1 + 4, 3 * m + 3) = "" Then Cells(2 * m1 + 4, 3 * m + 3) = bjCells(2 * m1 + 4, 3 * m + 4) = kc(0)Cells(2 * m1 + 4, 3 * m

13、 + 5) = kc(1)ElseCells(2 * m1 + 4, 3 * m + 3) = Cells(2 * m1 + 4, 3 * m + 3) & vbCrLf &bj End IfNextElsea = 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 Cells(2 * m1 + 4, 3 * m + 3) = bj Cel

14、ls(2 * m1 + 4, 3 * m + 4) = kc(0)Cells(2 * m1 + 4, 3 * m + 5) = kc (1)End IfNextNext Application.ScreenUpdating = True End Sub 2，根据总功课表生成班级课表和教师课表(数组) 根据总功课表生成班级课表和教师课表 .xls http:If Target.Address <> "$B$2" Then Exit Sub Dim bj$, d, Arr, i&, r1, j&, n&, ks, x&, y&

15、 bj = Target.ValueIf bj = "" Then MsgBox "班级不能为空。 ":Exit Subc5:g8.ClearContents:g3 = ""c10:g17.ClearContentsc19:g26.ClearContentsc28:g31.ClearContentsSet d = CreateObject("Scripting.Dictionary") Arr = Sheet6. a1.CurrentRegionFor i = 3 To UBound(Arr, 2) - 2If A

16、rr(2, i) <> "" Then d(Arr(2, i) = iNextFor i = 5 To UBound(Arr) Step 2If Arr(i, 1) = bj Then n = i:Exit ForNextg3 = Arr(n, 2)For i = 3 To 7j = d(Cells(4, i).Value)If i = 3 Thenks = 10For x = 1 To 2For y = 1 To 4Cells(ks, i) = Arr(n, j)Cells(ks + 1, i) = Arr(n + 1, j): j = j + 1: ks =

17、 ks + 2Nextks = ks + 1NextFor x = 1 To 2Cells(ks, i) = Arr(n, j)Cells(ks + 1, i) = Arr(n + 1, j): j = j + 1: ks = ks + 2NextElse:ks = 5For x = 1 To 2Cells(ks, i) = Arr(n, j)Cells(ks + 1, i) = Arr(n + 1, j): j = j + 1: ks = ks + 2Nextks = ks + 1For x = 1 To 2For y = 1 To 4Cells(ks, i) = Arr(n, j)Cell

18、s(ks + 1, i) = Arr(n + 1, j): j = j + 1: ks = ks + 2Nextks = ks + 1NextFor x = 1 To 2Cells(ks, i) = Arr(n, j)Cells(ks + 1, i) = Arr(n + 1, j): j = j + 1: ks = ks + 2NextEnd IfNextEnd Sub教师课表Private Sub Worksheet_Change(ByVal Target As Range)If Target.Address <> "$D$2" Then Exit SubDi

19、m js$, d, Arr, i&, r1, j&, n&, ks, x&, y&, t, aaDim b, r&, c&, d1, k, t1, xq$, xqq, km$, bj$js = Target.Valuexqq = Array(”星期一","星期二","星期三","星期四","星期五")c4:g7.ClearContentsc9:g16.ClearContentsc18:g25.ClearContentsc27:g30.ClearCon

20、tentsSet d = CreateObject("Scripting.Dictionary")Set d1 = CreateObject("Scripting.Dictionary")Arr = Sheet6.a1.CurrentRegionFor j = 3 To UBound(Arr, 2)If Arr(2, j) <> "" Then d1(Arr(2, j) = jNextk = d1.keys:t1 = d1.itemsFor x = 0 To UBound(k) - 1 xq = k(x)For j = t

21、1(x) To t1(x + 1) - 1For i = 6 To UBound(Arr) Step 2If Arr(i, j) <> "" Then d(Arr(i, j) = d(Arr(i, j) & xq & "," & j - t1(x) + 1 & "," & Arr(i - 1, j) & "," & Arr(i - 1, 1) & "|"NextNextNextx = UBound(k) xq = k(x

22、)For j = t1(x) To UBound(Arr, 2)For i = 6 To UBound(Arr) Step 2If Arr(i, j) <> "" Then d(Arr(i, j) = d(Arr(i, j) & xq & "," & j - t1(x) + 1 & "," & Arr(i - 1, j) & "," & Arr(i - 1, 1) & "|"NextNextIf d.exists(js)

23、 The n t = d(js) Else MsgBo>没有这个教师。"：Exit Subt = Left(t, Len(t) - 1)If InStr(t, "|") Thenaa = Split(t, "|")For j = 0 To UBound(aa) b = Split(aa(j), ",") xq = b(0):c = Val(b(1):km = b(2):bj = b(3)l = Application.Match(xq, xqq, 0) + 2 If xq = xqq(0) Then ks = xqy(

24、c)Elseks = xqe(c)End IfCells(ks, l) = kmCells(ks + 1, l) = bjNextElseb = Split(t, ",")xq = b(0):c = Val(b(1):km = b(2):bj = b(3)l = Application.Match(xq, xqq, 0) + 2If xq = xqq(0) Thenks = xqy(c)Elseks = xqe(c)End IfCells(ks, l) = kmCells(ks + 1, l) = bjEnd IfEnd SubFunction xqy(c) Select

25、Case c Case 1, 2, 3, 4 xqy = 2 * c + 7 Case 5, 6, 7, 8 xqy = 2 * c + 8 Case 9, 10 xqy = 2 * c + 9 End Select End Function Function xqe(c) Select Case c Case 1, 2 xqe = 2 * c + 2 Case 3, 4, 5, 6 xqe = 2 * c + 3 Case 7, 8, 9, 10 xqe = 2 * c + 4 Case 11, 12 xqe = 2 * c + 5 End SelectEnd Function批量打印Dim

26、 Arrjs(), Arrbj(), bj, jsPrivate Sub CommandButton1_Click()If bj = 1 ThenSheets(班级课表 ”).ActivateFor i = 0 To ListBox1. ListCount - 1If ListBox1.Selected(i) Thenb2 = ListBox1.List(i)a1:g31.PrintOutEnd IfNextElseIf js = 1 ThenSheets("教师课表 ”).ActivateFor i = 0 To ListBox1.ListCount - 1If ListBox1.

27、Selected(i) Thend2 = ListBox1.List(i)a1:g30.PrintOut End IfNextEnd IfMsgBox "打印结束。 "End SubPrivate Sub CommandButton2_Click() UserForm1.HideEnd SubPrivate Sub OptionButton1_Click()If OptionButton1.Value = True ThenMe.ListBox1.ClearMe.ListBox1.List = Arrbj bj = 1: js = 0End IfEnd SubPrivate

28、 Sub OptionButton2_Click()If OptionButton2. Value = True ThenMe.ListBox1.ClearMe.ListBox1.List = Arrjsjs = 1: bj = 0End IfEnd SubPrivate Sub UserForm_Initialize()Dim Myr&, Arr, i&With Sheet8Myr = .Cells(Rows.Count, 2).End(xlUp).RowArr = .Range("b3:b" & Myr)ReDim Arrjs(1 To UBou

29、nd(Arr)For i = 1 To UBound(Arr)Arrjs(i) = Arr(i, 1)NextEnd WithWith Sheet1Myr = .Cells(Rows.Count, 2).End(xlUp).Row Arr = .Range("a3:a" & Myr)ReDim Arrbj(1 To UBound(Arr)For i = 1 To UBound(Arr)Arrbj(i) = Arr(i, 1)NextEnd WithEnd Sub3，排课表显示(字典) http:排课0823.xlsPrivate Sub Worksheet_Acti

30、vate()Dim d, k, Arr, x&, col&, js$Set d = CreateObject("Scripting.Dictionary") Arr = c5:au21For col = 1 To UBound(Arr, 2)For x = 2 To UBound(Arr) Step 2 js = Arr(x, col) d(js) = ""Next xNext colk = d.keysWith b22.Validation.Delete.Add Type:=xlValidateList, AlertStyle:=xlV

31、alidAlertStop, _Operator:=xlBetween, Formula1:=Join(d.keys, ",")End WithEnd SubPrivate Sub Worksheet_Change(ByVal Target As Range)If Target.Count > 1 Then Exit SubIf Target.Address <> "$B$22" Then Exit SubCall pgEnd SubSub pg()Dim Arr, Arr1, js$, col&, x&Arr = c5

32、:au21c23:g31.ClearArr1 = c23:g31js = b22For col = 1 To UBound(Arr, 2)For x = 2 To UBound(Arr) Step 2If Arr(x, col) = js ThenArr1(x / 2, 1 + (col - 1) / 9) = Cells(4, col + 2)End IfNext xNext colc23.Resize(9, 5) = Arr1End Sub4，课表系统显示(字典) http: 9xx1天课表系统0926.xlsPublic nm$Sub cax()Dim i&, Myr&,

33、 Myc%, ArrDim d(2), k, t, t1, t2, x$, Arr1Set d(0) = CreateObject("Scripting.Dictionary")Set d(1) = CreateObject("Scripting.Dictionary")Set d(2) = CreateObject("Scripting.Dictionary")Application.ScreenUpdating = FalseSheet3. ActivateMyr = 27Myc = iv3.End(xlToLeft).Colum

34、nArr = Range("c3", Cells(Myr, Myc)For col = 1 To UBound(Arr, 2)For i = 3 To UBound(Arr) Step 2If Arr(i, col) = nm And Arr(i, col) <> "" Thenx = Arr(i - 1, col) & "" & Arr(1, col)If i < 18 Then d(0)(x) = d(0)(x) + 1ElseIf i < 20 Then d(1)(x) = d(1)(x)

35、 + 1Else d(2)(x) = d(2)(x) + 1End IfEnd IfNextNextk = d(0).keyst = d(0).itemst1 = d(1).itemst2 = d(2).itemsSheet7.Activate b8:e200.Clear b8.Resize(d(0).Count, 1) = Application.Transpose(k) c8.Resize(d(0).Count, 1) = Application.Transpose(t) If UBound(t1) >= 0 Thend8.Resize(d(1) .Count, 1) = Appli

36、cation.Transpose(t1)End IfIf UBound(t2) >= 0 Thene8.Resize(d(2) .Count, 1) = Application.Transpose(t2)End IfMyr = b65536.End(xlUp).Row + 1 Cells(Myr, 2) = "总计 "Cells(Myr, 3).Formula = "=sum(r8c: r-1c)"Cells(Myr, 3).AutoFill Cells(Myr, 3).Resize(1, 3)Cells(8, 2).Resize(d(0).Cou

37、nt + 1, 4).Borders.LineStyle = 1 Application.ScreenUpdating = True End Sub'以下代码放在 Sheet7 里面Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit SubIf Target.Address <> "$B$4" Then Exit Sub nm = Target.ValueCall caxEnd Sub5，高中课程分配(字典) http:任课分配0215.

38、xlsPrivate Sub CommandButton1_Click()Set d = CreateObject("scripting.dictionary")Set dd = CreateObject("scripting.dictionary")Set ddd = CreateObject("scripting.dictionary")With Sheets('课程总表")ro = .a65536.End(3).Rowcl = .iv3.End(xlToLeft).Columnar = .Range(.a4,

39、.Cells(ro, cl)End WithFor r = 1 To UBound(ar) Step 2 ban = ar(r, 1)For c = 2 To clIf ar(r + 1, c) <> "" Thenv = ar(r + 1, c) & "*" & ban & "*" & ar(r, c) ' 教师、班、课程 d(v) = d(v) + 1End IfNext cNext rk = d.keysFor i = 0 To d.Count - 1v = Split(k(i

40、), "*") dd(v(0) = dd(v(0) & v(1) & v(2) & "共" & d(k(i) & "节" ddd(v(0) = ddd(v(0) + d(k(i)Next i k = dd.keys a3:d1000.ClearContents For i = 0 To dd.Count - 1 Range("a" & i + 3) = i + 1 Range("b" & i + 3) = k(i) Range("

41、c" & i + 3) = ddd(k(i)Range("d" & i + 3) = dd(k(i)Next iEnd Sub6，高如何将任课表中的科目填入到名单对应姓名的位置6，如何将任课表中的科目填入到名单对应姓名的位置(字典) http:1.htmltest0919a.xlsDim d As New DictionaryArr = Sheet1.a1.CurrentRegionFor i = 6 To UBound(Arr) Step 2bj = Arr(i - 1, 1):nj = Left(bj, 1):bb = Mid(bj, 3, 1

42、)d1(i) = nj & "," & bbFor j = 3 To UBound(Arr, 2)If Arr(i, j) <> "" Then d(Arr(i, j) = d(Arr(i, j) & j & ","NextNextk = d.keys: t = d.itemsSet r1 = Sheet1.Rows(2).Find(xq, , , 1) col = r1.ColumnSet r1 = Sheet1.Rows(3) .Find(wb, Sheet 1.Cells(3, col

43、 - 1), , 1) col = r1.ColumnIf ks = js Then cc = col - 1 + ksFor i = 6 To UBound(Arr) Step 2aa = aa & Arr(i, cc) & "," & d1(i) & "," & Arr(i - 1, cc) & " " NextElseFor j = ks To js cc = col - 1 + jFor i = 6 To UBound(Arr) Step 2If Arr(i, cc) <&

44、gt; "" Then aa = aa & Arr(i, cc) & "," & d1(i) & "," & Arr(i - 1, cc) & "" NextNextEnd IfEnd SubSub cax()Call lqxsg9 = aaEnd SubSub daoc()Dim Brr, i&, bb, a, km$Call lqxsaa = Left(aa, Len(aa) - 1)Sheet3.Activate a3:d500 = "&quo

45、t;a3:d500.Borders.LineStyle = xlNone bb = Split(aa)ReDim Brr(1 To UBound(bb) + 1, 1 To 4)For i = 0 To UBound(bb)If bb(i) <> "" Then a = Split(bb(i), ",")Brr(i + 1, 1) = a(0) km = Left(a(3) , 1)Brr(i + 1, a(2) + 1) = a(1) & km End If Next a3.Resize(UBound(Brr), 4) = Brr

46、a3.Resize(UBound(Brr), 4).Borders.LineStyle = 1 End Sub8，课表查询(字典) 201-84-12 http:Sub lqxs(nm)Dim x&, k&, c%, i&, j&, hs, xm$, xq$, jsDim arr(1 To 2), crr, bh, y, r&, n& Application.ScreenUpdating = FalseWith Worksheets(” 课程总表")arr(1) = .Range("c3:bd20")arr(2) =

47、 .Range("c21:ak38")crr = .Range("an22:bd38")End WithFor Each y In Array(1, 5, 10)For i = 1 To UBound(crr)If crr(i, y + 1) = nm Thenbh = crr(i, y):GoTo 100End IfNextNextExit Sub100:hs = Array(5, 8, 10, 13, 16, 18)For k = 1 To 2For j = 1 To UBound(arr(k), 2) Step 18For i = j To j +

48、 14For x = 0 To UBound(hs) If arr(k)(hs(x), i) = bh Then xm = arr(k)(hs(x) - 1, i) & vbCrLf & arr(k)(2, i) xq = arr(k)(1, j):js = x + 1 c = d(xq):r = js * 2 + 3 Cells(r, c) = xm n = n + 1 End If Next Next Next Next i2 = n & " 节" Application.ScreenUpdating = True End SubPrivate

49、Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$B$2" Then Exit Sub Dim Brr, i& nm = Target.ValueSet d = CreateObject("scripting.dictionary") d5:h5 = "":d7:h7 = "":d9:h9 = "":d11:h11 = "":d13:h13 = "":d

50、15:h15 = ""Brr = a1:i15For i = 4 To 8 d(Brr(3, i) = i NextCall lqxs(nm)End Sub9，根据总功课表生成教师课表(字典数组) 201-94-17 http:1. htmlSub lqxs()Dim js$, d, Arr, i&, r1, j&, n&, ks, x&, y&, t, aaDim b, r&, c&, d1, k, t1, xq$, xqq, km$, bj$Dim Arr1, Brr1, Brr, djs, dd, jc, sjD

51、im dzd, dwd, kzk, tzt, kwk, twt, Crr, Drrxqq = Array(”星期一","星期二","星期三","星期四","星期五")Set d = CreateObject("Scripting.Dictionary")Set d1 = CreateObject("Scripting.Dictionary")Set djs = CreateObject("Scripting.Dictionary")Set dd

52、= CreateObject("Scripting.Dictionary")Set dzd = CreateObject("Scripting.Dictionary")Set dwd = CreateObject("Scripting.Dictionary")Arr1 = Sheet1.a1.CurrentRegionFor i = 3 To UBound(Arr1)djs(Arr1(i, 2) = Arr1(i, 5)NextBrr1 = Sheet1. a3.Resize(UBound(Arr1) - 2, 4)ReDim Brr

53、(1 To UBound(Brr1), 1 To 2)ReDim Crr(1 To UBound(Brr1), 1 To 2)ReDim Drr(1 To UBound(Brr1), 1 To 2)Arr = Sheet2. a1.CurrentRegionFor j = 3 To UBound(Arr, 2)If Arr(2, j) <> "" Then d1(Arr(2, j) = jNext k = d1.keys:t1 = d1.itemsFor x = 0 To UBound(k) - 1xq = k(x)For j = t1(x) To t1(x +

54、 1) - 1If Arr(3, j) <> "" Then sj = Arr(3, j)End IfFor i = 6 To UBound(Arr) Step 2Select Case sjCase "早晨 "jc = Arr(4, j)Case "上午 "jc = Arr(4, j) + 2Case "下午 "jc = Arr(4, j) + 6Case "晚上 "jc = Arr(4, j) + 10End SelectIf Arr(i, j) <> "" Then d(Arr(i, j) = d(Arr(i, j) & xq & "," & jc & "," & Arr(i - 1, j)& "," & Arr(i - 1, 1) & "|"NextNextNextFor i = 1