|
|
Sub 课时统计()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("课务分工")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 5 Then MsgBox "课务分工为空！": End
ar = .Range("a3:p" & r)
End With
For i = 3 To UBound(ar)
For j = 2 To UBound(ar, 2)
If ar(i, j) <> "" Then
zd = ar(i, 1) & "|" & ar(1, j)
d(zd) = ar(i, j)
End If
Next j
Next i
With Sheets("总课程表")
rs = .Cells(Rows.Count, 2).End(xlUp).Row
If rs < 5 Then MsgBox "总课程表为空！": End
br = .Range("a3:ao" & rs)
End With
Dim arr()
ReDim arr(1 To 1000, 1 To 5)
For i = 3 To UBound(br)
For j = 2 To UBound(br, 2)
If br(i, j) <> "" Then
zd = br(i, 1) & "|" & br(i, j)
If d.exists(zd) Then
xm = d(zd)
t = dc(xm)
If t = "" Then
k = k + 1
dc(xm) = k
t = k
arr(k, 1) = k
arr(k, 3) = xm
End If
If arr(t, 2) = "" Then
arr(t, 2) = br(i, j)
Else
arr(t, 2) = arr(t, 2) & "|" & br(i, j)
End If
If arr(t, 4) = "" Then
arr(t, 4) = br(i, 1)
Else
arr(t, 4) = arr(t, 4) & "|" & br(i, 1)
End If
arr(t, 5) = arr(t, 5) + 1
End If
End If
Next j
Next i
For i = 1 To k
dc.RemoveAll
rr = Split(arr(i, 2), "|")
zf = ""
For s = 0 To UBound(rr)
If Not dc.exists(rr(s)) Then
If zf = "" Then
zf = rr(s)
Else
zf = zf & "," & rr(s)
End If
dc(rr(s)) = ""
End If
Next s
arr(i, 2) = zf
dc.RemoveAll
rr = Split(arr(i, 4), "|")
zf = ""
For s = 0 To UBound(rr)
If Not dc.exists(rr(s)) Then
If zf = "" Then
zf = rr(s)
Else
zf = zf & "," & rr(s)
End If
dc(rr(s)) = ""
End If
Next s
arr(i, 4) = zf
Next i
With Sheets("教师任课情况统计")
.UsedRange.Offset(3).Borders.LineStyle = 0
.UsedRange.Offset(3) = Empty
.[a4].Resize(k, UBound(arr, 2)) = arr
.[a4].Resize(k, UBound(arr, 2)).Borders.LineStyle = 1
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-3-28 17:04
楼主
