分班课程表vba代码
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$B$2" Then Exit Sub
Dim tt, aa, j&, k, t, x$, y$, n&, ii&, zs, col%
Application.ScreenUpdating = False
[a4:n25].ClearContents
[a4:n25].Borders.LineStyle = xlNone
zs = Array("周一", "周二", "周三", "周四", "周五", "周六", "周日")
Set d1 = CreateObject("Scripting.Dictionary")
If d Is Nothing Then
Set d = CreateObject("Scripting.Dictionary")
Arr = Sheet1.[a1].CurrentRegion
For i = 3 To UBound(Arr)
d(Arr(i, 1)) = d(Arr(i, 1)) & i & ","
Next
End If
tt = d(Target.Value)
tt = Left(tt, Len(tt) - 1)
If InStr(tt, ",") Then
aa = Split(tt, ",")
For j = 0 To UBound(aa)
x = Arr(aa(j), 3): y = Arr(aa(j), 4)
If d1.exists(x) = False Then Set d1(x) = CreateObject("Scripting.Dictionary")
d1(x)(y) = aa(j)
Next
Else
x = Arr(tt, 3): y = Arr(tt, 4)
If d1.exists(x) = False Then Set d1(x) = CreateObject("Scripting.Dictionary")
d1(x)(y) = i
End If
k = d1.keys: t = d1.items: n = 3
For i = 0 To UBound(k)
n = n + 1
kk = t(i).keys: tt = t(i).items
For ii = 0 To UBound(kk)
Cells(n, 2) = k(i)
If kk(ii) <> "" Then
col = Application.Match(kk(ii), zs, 0) + 2
Cells(n, col) = Arr(tt(ii), 5) & Arr(tt(ii), 6)
Else
Cells(n, 9) = Arr(tt(ii), 6)
End If
For j = 7 To 11
Cells(n, j + 3) = Arr(tt(ii), j)
Next
Next
Next
[a4].Resize(n - 3, 14).Borders.LineStyle = 1
Application.ScreenUpdating = True
End Sub