Excel VBA_排课表显示实例集锦

1，排课表显示（字典套字典）

‘/thread-1111571-1-1.html

‘求助课表中如何自动合并单元格.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")

Sheet3.Activate

[b4:b500].ClearContents

[d4:ab500].ClearContents

Arr = Sheet1.[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 = Sheet4.[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 = "" Then Exit Sub

Application.ScreenUpdating = False

Set d = CreateObject("Scripting.Dictionary")

xinq = Array("星期一", "星期二", "星期三", "星期四", "星期五")

col = Array("1、2", "3、4", "5、6", "7、8", "9、10")

[c4:q13].ClearContents

Arr = Sheet1.[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 = 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

Next

Next

k = d.keys: t = d.items: n = 3

For 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