课表制作

jx928867128 · 发表于 2023-2-9 19:08

工作簿1.rar (15.83 KB, 下载次数: 10)

chxw68 · 发表于 2023-2-9 21:16

教师课表代码：

Sub jskb()
Dim r%, i%
Dim arr, brr
Dim d As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
With Worksheets("计划表")
arr = .Range("a1").CurrentRegion
For i = 3 To UBound(arr) Step 3
For j = 3 To UBound(arr, 2)
If Len(arr(i, j)) <> 0 Then
If Not d.exists(arr(i + 1, j)) Then
Set d(arr(i + 1, j)) = CreateObject("scripting.dictionary")
End If
d(arr(i + 1, j))(arr(i, 1)) = Array(arr(2, j), arr(i, j))
End If
Next
Next
brr = .Range("c16:i24")
End With
With Worksheets("教师课表")
.Cells.Clear
.ResetAllPageBreaks
r = 1
For Each aa In d.keys
With .Cells(r, 1)
.Value = aa & "老师选科课表"
.Resize(1, 9).Merge
With .Font
.Name = "微软雅黑"
.Size = 16
.Bold = True
End With
End With
.Cells(r + 1, 1).Resize(1, 9) = Array("午别", "节次", "星期一", "星期二", "星期三", "星期四", "星期五", "星期六", "星期日")
With .Cells(r + 2, 1)
.Value = "上午"
.Resize(15, 1).Merge
End With
With .Cells(r + 17, 1)
.Value = "下午"
.Resize(12, 1).Merge
End With
For k = 1 To 9
With .Cells(r + k * 3 - 1, 2)
.Value = k
.Resize(3, 1).Merge
End With
Next
ReDim crr(1 To 27, 1 To 7)
For i = 1 To UBound(brr)
m = i * 3 - 2
For j = 1 To UBound(brr, 2)
If Len(brr(i, j)) <> 0 Then
If d(aa).exists(brr(i, j)) Then
drr = d(aa)(brr(i, j))
crr(m, j) = brr(i, j)
crr(m + 1, j) = drr(1)
crr(m + 2, j) = drr(0)
End If
End If
Next
Next
.Cells(r + 2, 3).Resize(UBound(crr), UBound(crr, 2)) = crr
With .Cells(r + 1, 1).Resize(28, 9)
.Borders.LineStyle = xlContinuous
With .Font
.Name = "微软雅黑"
.Size = 11
End With
End With
.Rows(r).RowHeight = 30
.Rows(r + 1).Resize(28).RowHeight = 18
r = r + 29
.HPageBreaks.Add before:=.Rows(r)
Next
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
End Sub

复制代码

chxw68 · 发表于 2023-2-9 21:22

两段代码都写好了。

jx928867128 · 发表于 2023-2-9 22:52

chxw68 发表于 2023-2-9 21:22
两段代码都写好了。

谢谢老师的多次帮忙，测试时发现教室课表不对，我需要的是按授课教室进行制作教室课表，您帮我写的程序是按学科进行制作，因为同一课组中会有重复的学科。

chxw68 · 发表于 2023-2-10 08:51

修改好了。

jx928867128 · 发表于 2023-2-10 09:31

chxw68 发表于 2023-2-10 08:51
修改好了。

十分感谢老师的再次帮忙，我下载后明明开启了宏，但运行按钮时出现图片中的提示，不知道是我哪里操作不对？

chxw68 · 发表于 2023-2-10 09:32

jx928867128 发表于 2023-2-10 09:31
十分感谢老师的再次帮忙，我下载后明明开启了宏，但运行按钮时出现图片中的提示，不知道是我哪里操作不对 ...

看看你的宏安全性设置。

jx928867128 · 发表于 2023-2-10 09:42

chxw68 发表于 2023-2-10 09:32
看看你的宏安全性设置。

谢谢您的再次回复，我的宏安全性设置是按图片上那样设置的

chxw68 · 发表于 2023-2-10 09:43

jx928867128 发表于 2023-2-10 09:42
谢谢您的再次回复，我的宏安全性设置是按图片上那样设置的

设置没有问题。我就不知道问题原因了。

		自动登录	找回密码
密码			免费注册

[求助] 课表制作

评分

评分