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

zhengqiyu

这是原始表格，学科和教师姓名用换行符分割， 通常两列为一个班，有大量合并单元格，因为部分课程分单双周
想要汇总到分班级学科汇总表效果如下：

文件在附件里面

3190496160

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("全部班级")
    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
With Sheets("班级学科汇总")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    y = .Cells(1, Columns.Count).End(xlToLeft).Column
    If r > 1 Then .Range(.Cells(2, 1), .Cells(r, y)).Borders.LineStyle = 0: .Range(.Cells(2, 1), .Cells(r, y)) = ""
    ar = .Range(.Cells(1, 1), .Cells(rs, y))
    For j = 2 To UBound(ar, 2)
        d(ar(1, j)) = j
    Next j
    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)
                    xm = Split(br(i, j), Chr(10))(1)
                    lh = d(km)
                    If lh <> "" Then
                        ar(t, lh) = xm
                    End If
                End If
            End If
        Next i
    Next j
    .[a1].Resize(k, UBound(ar, 2)) = ar
    .[a1].Resize(k, UBound(ar, 2)).Borders.LineStyle = 1
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

总课表.rar (234.74 KB, 下载次数: 11)

2023-12-12 08:46 上传

点击文件名下载附件

sunya_0529

WPS里的JSA练习一下——

zhengqiyu

sunya_0529 发表于 2023-12-12 11:44
WPS里的JSA练习一下——

可否用VbA写

zhengqiyu

3190496160 发表于 2023-12-12 08:46

科目不完整，有错位，谢谢！

zhengqiyu

3190496160 发表于 2023-12-12 08:46

科目不完整，有错位哈

zhengqiyu

3190496160 发表于 2023-12-12 08:45
Sub 提取()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant

科目不完整，有的有错位哈，比如政治就没有

3190496160

zhengqiyu 发表于 2023-12-12 12:13
科目不完整，有的有错位哈，比如政治就没有

兄弟，科目得你自己在结果表的第一行自己添加，不是什么都得代码来帮你做的
另外，错位，最起码举个例子呀，不然咋帮你呢？

zhengqiyu

3190496160 发表于 2023-12-12 12:51
兄弟，科目得你自己在结果表的第一行自己添加，不是什么都得代码来帮你做的
另外，错位，最起码举个例子 ...

明白了。谢谢