Class schedule VBA code

Class schedule VBA code

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) 'd1(x)(y) + 1
    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