课程表问题再求好心人帮忙（已解决，正解在20楼，在这里统一谢过各位好心哈）

jx928867128

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

2023-3-21 09:42 上传

点击文件名下载附件

鄂龙蒙

【教师课程总表】.rar (71.42 KB, 下载次数: 20)

2023-3-21 10:15 上传

点击文件名下载附件

jx928867128

鄂龙蒙 发表于 2023-3-21 10:15

谢谢老师的回贴，我需要的是做成教师课程总表，而不是汇总表

鄂龙蒙

【课程总表】？

gbgbxgb

就楼主当前的需求看，教师名册这个工作表是多余的，除非楼主另有它用。

3190496160

Sub 生成课程总表()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ar As Variant, br As Variant, cr As Variant, arr As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("汇总")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    y = .Cells(4, Columns.Count).End(xlToLeft).Column
    If r < 5 Or y < 5 Then MsgBox "汇总为空！": End
    ar = .Range(.Cells(3, 1), .Cells(r, y))
End With
With Sheets("教师名册")
    rs = .Cells(Rows.Count, 2).End(xlUp).Row
    If rs < 2 Then MsgBox "教师名册为空！": End
    br = .Range("b2:b" & rs)
End With
With Sheets("课程清单")
    ws = .Cells(Rows.Count, 1).End(xlUp).Row
    If ws < 2 Then MsgBox "课程清单为空！": End
    cr = .Range("a1:b" & ws)
End With
With Sheets("教师课程总表")
    .UsedRange.Clear
    .[a3].Resize(2, UBound(ar, 2)) = ar
    .[a5].Resize(UBound(br), 1) = br
    arr = .Range(.Cells(3, 1), .Cells(rs + 4, y))
    For i = 3 To UBound(arr)
        If Trim(arr(i, 1)) <> "" Then
            d(Trim(arr(i, 1))) = i
        End If
    Next i
    For j = 3 To UBound(arr, 2)
        If Trim(arr(1, j)) = "" Then arr(1, j) = arr(1, j - 1)
        If Trim(arr(1, j)) <> "" And Trim(arr(2, j)) <> "" Then
            zd = Trim(arr(1, j)) & "|" & Trim(arr(2, j))
            d(zd) = j
        End If
    Next j
    For i = 2 To UBound(cr)
        If Trim(cr(i, 1)) <> "" Then
            rr = Split(cr(i, 1), "|")
            xh = d(Trim(rr(0)))
            zf = Trim(rr(1)) & "|" & Trim(rr(2))
            lh = d(zf)
            If xh <> "" And lh <> "" Then
                arr(xh, lh) = cr(i, 2)
            End If
        End If
    Next i
     .Range(.Cells(3, 1), .Cells(rs + 4, y)) = arr
     For j = 2 To y Step 13
        .Cells(3, j).Resize(1, 13).Merge
    Next j
End With
Set d = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

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

2023-3-21 11:51 上传

点击文件名下载附件

3190496160

结果为核对，代码仅供参考

3190496160

Sub 生成课程总表22()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ar As Variant, br As Variant, cr As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Dim arr()
With Sheets("汇总")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    y = .Cells(4, Columns.Count).End(xlToLeft).Column
    If r < 5 Or y < 5 Then MsgBox "汇总为空！": End
    ar = .Range(.Cells(3, 1), .Cells(r, y))
End With
With Sheets("教师课程总表")
    .UsedRange.Clear
    ReDim arr(1 To 1000, 1 To UBound(ar, 2))
    For j = 3 To UBound(ar, 2)
        arr(1, j) = ar(1, j)
        arr(2, j) = ar(2, j)
    Next j
    k = 2
    For i = 3 To UBound(ar)
        For j = 2 To UBound(ar, 2)
            If Trim(ar(i, j)) <> "" Then
                If InStr(ar(i, j), Chr(10)) > 0 Then
                    rr = Split(Trim(ar(i, j)), Chr(10))
                    xm = Trim(rr(1))
                    t = d(xm)
                    If t = "" Then
                        k = k + 1
                        d(xm) = k
                        t = k
                        arr(k, 1) = xm
                    End If
                    If arr(t, j) = "" Then
                        arr(t, j) = rr(0) & "/" & ar(i, 1)
                    Else
                        arr(t, j) = arr(t, j) & Chr(10) & rr(0) & "/" & ar(i, 1)
                    End If
                End If
            End If
        Next j
    Next i
    .[a3].Resize(k, UBound(arr, 2)) = arr
End With
Set d = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub