|
|
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
For i = 2 To UBound(br)
If Trim(br(i, 1)) <> "" Then
d(Trim(br(i, 1))) = br(i, 2)
End If
Next i
With Sheets("班课表")
m = 19
ws = .Cells(Rows.Count, 1).End(xlUp).Row
If ws >= 19 Then .Rows("19:" & ws).Delete
For j = 4 To UBound(ar, 2)
If Trim(ar(1, j)) <> "" Then
If j = 4 Then
.Range("b5:f18") = Empty
arr = .Range("a1:f18")
arr(1, 1) = "2023学年 第二学期 " & ar(1, j) & " 班课程表"
arr(3, 2) = ar(1, j)
arr(3, 6) = d(Trim(ar(1, j)))
lh = 1
For i = 2 To UBound(ar) Step 14
lh = lh + 1
xh = 4
For s = i To i + 13
xh = xh + 1
arr(xh, lh) = ar(s, j)
Next s
Next i
arr(9, 2) = "课 间 活 动"
arr(16, 2) = "眼 保 健 操'"
.Range("a1:f18") = arr
Else
.Rows("1:18").Copy .Cells(m, 1)
.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) = ar(1, j)
arr(3, 6) = d(Trim(ar(1, j)))
arr(1, 1) = "2023学年 第二学期 " & ar(1, j) & " 班课程表"
lh = 1
For i = 2 To UBound(ar) Step 14
lh = lh + 1
xh = 4
For s = i To i + 13
xh = xh + 1
arr(xh, lh) = ar(s, j)
Next s
Next i
arr(9, 2) = "课 间 活 动"
arr(16, 2) = "眼 保 健 操'"
.Range("a" & m & ":f" & m + 17) = arr
m = m + 18
End If
End If
Next j
.Select
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
评分
-
1
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-10-8 14:16
楼主
