|
|
Sub 教师课表()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim i As Long, r As Long, rs As Long
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("总课表")
r = 73
y = .Cells(3, Columns.Count).End(xlToLeft).Column
If r < 5 Then MsgBox "导入蔬菜定价 工作表为空，请先导入数据！": End
ar = .Range(.Cells(3, 1), .Cells(r, y))
End With
With Sheets("名册表")
rs = .Cells(Rows.Count, 1).End(xlUp).Row
br = .Range(.Cells(1, 1), .Cells(rs, 2))
End With
With Sheets("教师课表")
m = 1
ws = .Cells(Rows.Count, 1).End(xlUp).Row
If ws >= 19 Then .Rows("19:" & ws).Delete
For i = 2 To UBound(br)
If Trim(br(i, 2)) <> "" Then
lh = 1: xh = 4
kk = 0
If i = 2 Then GoTo 10
.Rows("1:18").Copy .Cells(m, 1)
10:
.Range("b" & m + 4 & ":f" & m + 17) = Empty
.Cells(m + 2, 2) = ""
.Cells(m + 2, 6) = ""
arr = .Range("a" & m & ":f" & m + 17)
arr(3, 2) = br(i, 2)
For s = 3 To UBound(ar) Step 14
lh = lh + 1: xh = 4
For ss = s To s + 13 Step 1
If ss <= UBound(ar) Then
xh = xh + 1
For j = 4 To UBound(ar, 2)
If Not IsError(ar(ss, j)) Then
If Trim(ar(ss, j)) = Trim(br(i, 2)) Then
arr(xh, lh) = ar(1, j)
arr(xh + 1, lh) = ar(ss - 1, j)
kk = kk + 1
End If
End If
Next j
End If
Next ss
Next s
arr(3, 5) = kk
.Range("a" & m & ":f" & m + 17) = arr
m = m + 18
End If
Next i
.Select
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
楼主: tdpca
沪公网安备 31011702000001号 沪ICP备11019229号-2
楼主
发表于 2023-10-10 15:44
