课程表求帮忙

jx928867128

教师课程总表.rar (68.11 KB, 下载次数: 13)

2023-3-21 07:36 上传

点击文件名下载附件

yellowhawk

这个有点麻烦哦！

清风竹-

请看附件。

lushang2018

lushang2018

点击教师汇总按钮即可

ykcbf1100

附件请参考。。。

ZHLK

Sub demo()
Dim arr(1 To 22, 1 To 13, 1 To 9) As String

Application.ScreenUpdating = False
Sheets("课程清单").Select
For i = 2 To 1476
    arr(班级(Cells(i, 5)), 节次(Cells(i, 3)), 1) = Cells(i, 5)
    arr(班级(Cells(i, 5)), 节次(Cells(i, 3)), 2) = Cells(i, 3)
    arr(班级(Cells(i, 5)), 节次(Cells(i, 3)), 星期(Cells(i, 2)) + 2) = Cells(i, 4) & vbCrLf & Cells(i, 1)
Next i

a = 3
Sheets("sheet6").Select
Rows("3:10000").Delete Shift:=xlUp
For i = 1 To 22
    For j = 1 To 13
        For k = 1 To 9
            If arr(i, j, 1) <> "" Then
                Sheets("sheet6").Cells(a, k) = arr(i, j, k)
            Else
                a = a - 1
                Exit For
            End If
        Next k
        a = a + 1
    Next j
Next i

For i = 8 To Range("a65320").End(xlUp).Row
    If Range("A" & i) <> Range("A" & i - 1) Then
        ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=Range("A" & i)
    End If
Next i

Range("a2:i" & Range("a65320").End(xlUp).Row).Borders.LineStyle = 1
Sheets("sheet6").Select

Application.ScreenUpdating = True

End Sub

ZHLK

希望能帮上你

3190496160

这个问题，咋又来求助呢？之前的代码不能解决你的问题？应该是可以的吧

gbgbxgb

奇怪，这么简单的问题要求助？
而且，据前楼层的跟帖，似乎楼主为此问题发了重重求助帖。