求助 按总课表分班级学科导出任课教师

zhengqiyu

zhengqiyu 发表于 2023-12-12 14:27
明白了。谢谢

我以为可以自动识别

3190496160

zhengqiyu 发表于 2023-12-12 14:29
我以为可以自动识别

要自动识别也不是不可以，事先也没说呀
另外，究竟如何错位，要有个具体的说明

zhengqiyu

3190496160 发表于 2023-12-12 14:40
要自动识别也不是不可以，事先也没说呀
另外，究竟如何错位，要有个具体的说明

没有错位，是不同科目，本来就是相同的人哈，能自动识别科目最好哈，应该字典就可以吧

3190496160

Sub 提取()
Application.ScreenUpdating = False
Dim br As Variant
Dim ar()
Dim i As Long, r As Long, rs As Long
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("全部班级")
    rs = .Cells(Rows.Count, 4).End(xlUp).Row
    ys = .Cells(4, Columns.Count).End(xlToLeft).Column + 1
    br = .Range(.Cells(4, 2), .Cells(rs, ys))
End With
ReDim ar(1 To UBound(br, 2), 1 To 50)
ar(1, 1) = "班级"
With Sheets("班级学科汇总")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    y = .Cells(1, Columns.Count).End(xlToLeft).Column
    If r > 1 Then .Range(.Cells(1, 1), .Cells(r, y)).Borders.LineStyle = 0: .Range(.Cells(1, 1), .Cells(r, y)) = ""
    y = 1: k = 1
    For j = 5 To UBound(br, 2)
        If br(1, j) = "" Then br(1, j) = br(1, j - 1)
        t = d(br(1, j))
        If t = "" Then
            k = k + 1
            d(br(1, j)) = k
            t = k
            ar(k, 1) = br(1, j)
        End If
        For i = 3 To UBound(br)
            If Trim(br(i, j)) <> "" Then
                If InStr(br(i, j), Chr(10)) > 0 Then
                    km = Split(br(i, j), Chr(10))(0)
                    lh = d(km)
                    If lh = "" Then
                        y = y + 1
                        d(km) = y
                        lh = y
                        ar(1, y) = km
                    End If
                    xm = Split(br(i, j), Chr(10))(1)
                    ar(t, lh) = xm
                End If
            End If
        Next i
    Next j
    .[a1].Resize(k, y) = ar
    .[a1].Resize(k, y).Borders.LineStyle = 1
End With
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

科目可以自动生成了
总课表.rar (238.95 KB, 下载次数: 8)

2023-12-13 08:14 上传

点击文件名下载附件

kingc138

用水晶排课啊！很好用