Excel VBA_排课表显示实例集锦.doc

1，排课表显示（字典套字典）/thread-1111571-1-1.html求助课表中如何自动合并单元格.xls2014-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 = Array(星期一, 星期二, 星期三, 星期四, 星期五)col = Array(1、2, 3、4, 5、6, 7、8, 9、10)Sheet3.Activateb4:b500.ClearContentsd4:ab500.ClearContentsArr = Sheet1.a1.CurrentRegionFor 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 NextNextk = d.keys: t = d.items: n = 1For 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 NextNextApplication.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.Validation .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)xinq = Array(星期一, 星期二, 星期三, 星期四, 星期五)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 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 = Target.Value 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 NextNextk = d.keys: t = d.items: n = 3For i = 0 To UBound(k) 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 If Cells(2 * m1 + 4, 3 * m + 3) = Then Cells(2 * m1 + 4, 3 * m + 3) = bj Cells(2 * m1 + 4, 3 * m + 4) = kc(0) Cells(2 * m1 + 4, 3 * m + 5) = kc(1) Else Cells(2 * m1 + 4, 3 * m + 3) = Cells(2 * m1 + 4, 3 * m + 3) & 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 Cells(2 * m1 + 4, 3 * m + 3) = bj Cells(2 * m1 + 4, 3 * m + 4) = kc(0) Cells(2 * m1 + 4, 3 * m + 5) = kc(1) End If NextNextApplication.ScreenUpdating = TrueEnd Sub2，根据总功课表生成班级课表和教师课表（数组）根据总功课表生成班级课表和教师课表.xls/forum.php?mod=viewthread&tid=1113238&page=2#lastpostPrivate Sub Worksheet_Change(ByVal Target As Range)If Target.Address $B$2 Then Exit SubDim bj$, d, Arr, i&, r1, j&, n&, ks, x&, y&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) - 2 If Arr(2, i) Then d(Arr(2, i) = iNextFor i = 5 To UBound(Arr) Step 2 If Arr(i, 1) = bj Then n = i: Exit ForNextg3 = Arr(n, 2) For i = 3 To 7 j = d(Cells(4, i).Value) If i = 3 Then ks = 10 For x = 1 To 2 For y = 1 To 4 Cells(ks, i) = Arr(n, j) Cells(ks + 1, i) = Arr(n + 1, j): j = j + 1: ks = ks + 2 Next ks = ks + 1 Next For x = 1 To 2 Cells(ks, i) = Arr(n, j) Cells(ks + 1, i) = Arr(n + 1, j): j = j + 1: ks = ks + 2 Next Else: ks = 5 For x = 1 To 2 Cells(ks, i) = Arr(n, j) Cells(ks + 1, i) = Arr(n + 1, j): j = j + 1: ks = ks + 2 Next ks = ks + 1 For x = 1 To 2 For y = 1 To 4 Cells(ks, i) = Arr(n, j) Cells(ks + 1, i) = Arr(n + 1, j): j = j + 1: ks = ks + 2 Next ks = ks + 1 Next For x = 1 To 2 Cells(ks, i) = Arr(n, j) Cells(ks + 1, i) = Arr(n + 1, j): j = j + 1: ks = ks + 2 Next End If NextEnd Sub教师课表Private Sub Worksheet_Change(ByVal Target As Range)If Target.Address $D$2 Then Exit SubDim 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.ClearContentsSet 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 = t1(x) To t1(x + 1) - 1 For i = 6 To UBound(Arr) Step 2 If 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) & | Next NextNextx = UBound(k)xq = k(x)For j = t1(x) To UBound(Arr, 2) For i = 6 To UBound(Arr) Step 2 If 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) Then t = d(js) Else MsgBox 没有这个教师。: Exit Subt = Left(t, Len(t) - 1)If InStr(t, |) Then aa = 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(c) Else ks = xqe(c) End If Cells(ks, l) = km Cells(ks + 1, l) = bj NextElse b = Split(t, ,) 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(c) Else ks = xqe(c) End If Cells(ks, l) = km Cells(ks + 1, l) = bjEnd IfEnd SubFunction xqy(c)Select 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 + 9End SelectEnd FunctionFunction 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 + 5End SelectEnd Function批量打印Dim Arrjs(), Arrbj(), bj, jsPrivate Sub CommandButton1_Click()If bj = 1 Then Sheets(班级课表).Activate For i = 0 To ListBox1.ListCount - 1 If ListBox1.Selected(i) Then b2 = ListBox1.List(i) a1:g31.PrintOut End If NextElseIf js = 1 Then Sheets(教师课表).Activate For i = 0 To ListBox1.ListCount - 1 If ListBox1.Selected(i) Then d2 = ListBox1.List(i) a1:g30.PrintOut End If NextEnd IfMsgBox 打印结束。End SubPrivate Sub CommandButton2_Click()UserForm1.HideEnd SubPrivate Sub OptionButton1_Click()If OptionButton1.Value = True Then Me.ListBox1.Clear Me.ListBox1.List = Arrbj bj = 1: js = 0End IfEnd SubPrivate Sub OptionButton2_Click()If OptionButton2.Value = True Then Me.ListBox1.Clear Me.ListBox1.List = Arrjs js = 1: bj = 0End IfEnd SubPrivate Sub UserForm_Initialize()Dim Myr&, Arr, i&With Sheet8 Myr = .Cells(Rows.Count, 2).End(xlUp).Row Arr = .Range(b3:b & Myr) ReDim Arrjs(1 To UBound(Arr) For i = 1 To UBound(Arr) Arrjs(i) = Arr(i, 1) NextEnd WithWith Sheet1 Myr = .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，排课表显示（字典）/viewthread.php?tid=474737&pid=3104875&page=1&extra=page%3D1排课0823.xlsPrivate Sub Worksheet_Activate()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:=xlValidAlertStop, _ 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:au21c23:g31.ClearArr1 = c23:g31js = b22For col = 1 To UBound(Arr, 2) For x = 2 To UBound(Arr) Step 2 If Arr(x, col) = js Then Arr1(x / 2, 1 + (col - 1) / 9) = Cells(4, col + 2) End If Next xNext colc23.Resize(9, 5) = Arr1End Sub4，课表系统显示（字典）/viewthread.php?tid=630180&pid=4269164&page=1&extra=page%3D19班11天课表系统0926.xlsPublic nm$Sub cax()Dim i&, Myr&, 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).ColumnArr = Range(c3, Cells(Myr, Myc)For col = 1 To UBound(Arr, 2)For i = 3 To UBound(Arr) Step 2 If Arr(i, col) = nm And Arr(i, col) Then x = Arr(i - 1, col) & & Arr(1, col) If i 18 Then d(0)(x) = d(0)(x) + 1 ElseIf i = 0 Then d8.Resize(d(1).Count, 1) = Application.Transpose(t1)End IfIf UBound(t2) = 0 Then e8.Resize(d(2).Count, 1) = Application.Transpose(t2)End IfMyr = b65536.End(xlUp).Row + 1Cells(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).Count + 1, 4).Borders.LineStyle = 1Application.ScreenUpdating = TrueEnd Sub以下代码放在Sheet7里面Private Sub Worksheet_Change(ByVal Target As Range)If Target.Count 1 Then Exit SubIf Target.Address $B$4 Then Exit Subnm = Target.ValueCall caxEnd Sub5，高中课程分配（字典）/viewthread.php?tid=681318&page=1&extra=任课分配0215.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).Row cl = .iv3.End(xlToLeft).Column ar = .Range(.a4, .Cells(ro, cl) End With For r = 1 To UBound(ar) Step 2 ban = ar(r, 1) For c = 2 To cl If ar(r + 1, c) Then v = ar(r + 1, c) & * & ban & * & ar(r, c) 教师、班、课程 d(v) = d(v) + 1 End If Next c Next r k = d.keys For i = 0 To d.Count - 1 v = Split(k(i), *) 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(c & i + 3) = ddd(k(i) Range(d & i + 3) = dd(k(i) Next iEnd Sub6，高如何将任课表中的科目填入到名单对应姓名的位置6，如何将任课表中的科目填入到名单对应姓名的位置（字典）/thread-922624-2-1.htmltest0919a.xlsDim d As New DictionaryDim d1 As New DictionarySub 填充()Dim xm, rkb, rkkm, rlkm, rlxm, r, sckm, km, sSheet2.Activateb:c.ClearContentsrkb = Sheets(任课表).Range(b2:bi16)xm = Sheets(绩效名单).Range(a2:a241)rkkm = Sheets(任课表).Range(a2:a16)For i = 1 To UBound(rkb) For j = 1 To UBound(rkb, 2) If d.exists(rkb(i, j) = False Then Set d(rkb(i, j) = New Dictionary d(rkb(i, j)(rkkm(i, 1) = rkkm(i, 1) Next jNext ik = d.Keysk1 = d(k(0).itemsFor x = 1 To UBound(xm) If d.exists(xm(x, 1) Then s = d(xm(x, 1).items If IsArray(s) Then Cells(x + 1, 2).Resize(1, UBound(s) + 1) = s Else Cells(x + 1, 2) = s End If End IfNextSet d = NothingEnd Sub7，苏中课表查询（字典）/thread-1058020-1-1.html苏中课表查询求助0924.xlsDim aa$Sub lqxs()Dim Arr, i&, j&, xq$, wb$, ks, js, md$Dim d, k, t, d1, bj$, nj$, bb$Set d = CreateObject(Scripting.Dictionary)Set d1 = CreateObject(Scripting.Dictionary)Sheet2.Activateg9 = : aa = xq = g5.Value: wb = j5.Valueks = m5.Value: js = o5.Value: md = q5.ValueArr = Sheet1.a1.CurrentRegionFor i = 6 To UBound(Arr) Step 2 bj = Arr(i - 1, 1): nj = Left(bj, 1): bb = Mid(bj, 3, 1) d1(i) = nj & , & bb For 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, Sheet1.Cells(3, col - 1), , 1)col = r1.ColumnIf ks = js Then cc = col - 1 + ks For i = 6 To UBound(Arr) Step 2 aa = aa & Arr(i, cc) & , & d1(i) & , & Arr(i - 1, cc) & NextElse For j = ks To js cc = col - 1 + j For i = 6 To UBound(Arr) Step 2 If Arr(i, cc) Then aa = aa & Arr(i, cc) & , & d1(i) & , & Arr(i - 1, cc) & Next NextEnd IfEnd SubSub cax()Call lqxsg9 = aaEnd SubSub daoc()Dim Brr, i&, bb, a, km$Call lqxsaa = Left(aa, Len(aa) - 1)Sheet3.Activatea3:d500 = a3:d500.Borders.LineStyle = xlNonebb = 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 IfNexta3.Resize(UBound(Brr), 4) = Brra3.Resize(UBound(Brr), 4).Borders.LineStyle = 1End Sub8，课表查询（字典）2014-8-12/forum.php?mod=viewthread&tid=1143105&page=1#pid7799793Public nm$, dSub lqxs(nm) Dim x&, k&, c%, i&, j&, hs, xm$, xq$, js Dim arr(1 To 2), crr, bh, y, r&, n& Application.ScreenUpdating = False With Worksheets(课程总表) arr(1) = .Range(c3:bd20) arr(2) = .Range(c21:ak38) crr = .Range(an22:bd38) End With For Each y In Array(1, 5, 10) For i = 1 To UBound(crr) If crr(i, y + 1) = nm Then bh = crr(i, y): GoTo 100 End If Next Next Exit Sub100:hs = Array(5, 8, 10, 13, 16, 18) For k = 1 To 2 For j = 1 To UBound(arr(k), 2) Step 18 For i = j To j + 14 For 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 Nexti