[已解决]总课表生成教师和班级课表，感觉比排课软件还给力

雄鹰2013

Sub 练习2() '2017.9.18
Dim ar, br, cr, arr
Set d = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set d3 = CreateObject("scripting.dictionary")
ar = Sheets("表1").[a3].CurrentRegion
br = Sheets("表2").[a1].CurrentRegion
For i = 2 To UBound(br)
     For j = 3 To UBound(br, 2)
         If br(i, j) <> "" Then
            d(br(i, 2) & "," & br(i, j)) = br(i, 1) '对学科+班级指定老师
         End If
     Next j
Next i
For j = 5 To UBound(ar, 2)
     If ar(3, j) = "" Then ar(3, j) = ar(3, j - 1)
Next j
For i = 5 To UBound(ar)
     For j = 4 To UBound(ar, 2)
         x = ar(i, j) & "," & ar(4, j)
         If d(x) <> "" Then d2(d(x)) = d2(d(x)) & i & "," & j & "|" '将老师与总课表中的行列联系起来
     Next j
Next i
For Each k In d2.keys
     Sheets("样表").Copy after:=Sheets(Sheets.Count)
     With ActiveSheet
          .Name = k
          .[g2] = k
          cr = Split(d2(k), "|")
          For i = 0 To UBound(cr) - 1
              x = Split(cr(i), ",")(0)
              y = Split(cr(i), ",")(1)
              If x * y <> 0 Then
                 d3(ar(x, 3) & "," & ar(3, y)) = "七（" & ar(4, y) & "）" '第几节+星期几
              End If
          Next i
          arr = .[a1].CurrentRegion
          For i = 5 To UBound(arr)
              For j = 3 To UBound(arr, 2)
                  arr(i, j) = d3(arr(i, 2) & "," & arr(3, j))
              Next j
          Next i
          .[a1].CurrentRegion = arr
     End With
     d3.RemoveAll
Next k
End Sub