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

chxw68

1. Sub test2()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Dim reg As New RegExp
   
6.     Application.ScreenUpdating = False
   
7.     Application.DisplayAlerts = False
   
8.     Set d = CreateObject("scripting.dictionary")
   
9.     With reg
   
10.         .Global = False
    
11.         .Pattern = "'+|（[^）]*）"
    
12.     End With
    
13.     With Worksheets("汇总")
    
14.         c = .Cells(4, .Columns.Count).End(xlToLeft).Column
    
15.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
16.         arr = .Range("a3").Resize(r - 2, c)
    
17.     End With
    
18.     ls = c
    
19.     For i = 3 To UBound(arr)
    
20.         For j = 2 To UBound(arr, 2)
    
21.             arr(i, j) = reg.Replace(arr(i, j), Empty)
    
22.             If InStr(arr(i, j), vbLf) <> 0 Then
    
23.                 If InStr(arr(i, j), "/") = 0 Then
    
24.                     xm = Split(arr(i, j), vbLf)
    
25.                     If Not d.exists(xm(1)) Then
    
26.                         ReDim brr(1 To ls)
    
27.                         brr(1) = xm(1)
    
28.                         brr(j) = xm(0) & "/" & arr(i, 1)
    
29.                     Else
    
30.                         brr = d(xm(1))
    
31.                         brr(j) = brr(j) & vbLf & xm(0) & "/" & arr(i, 1)
    
32.                     End If
    
33.                     d(xm(1)) = brr
    
34.                 Else
    
35.                     xm1 = Split(arr(i, j), vbLf)
    
36.                     For x = 0 To UBound(xm1)
    
37.                         If InStr(xm1(x), "/") <> 0 Then
    
38.                             xm2 = Split(xm1(x), "/")
    
39.                             If Not d.exists(xm2(1)) Then
    
40.                                 ReDim brr(1 To ls)
    
41.                                 brr(1) = xm2(1)
    
42.                                 brr(j) = xm2(0) & "/" & arr(i, 1)
    
43.                             Else
    
44.                                 brr = d(xm2(1))
    
45.                                 brr(j) = brr(j) & vbLf & xm2(0) & "/" & arr(i, 1)
    
46.                             End If
    
47.                             d(xm2(1)) = brr
    
48.                         End If
    
49.                     Next
    
50.                 End If
    
51.             End If
    
52.         Next
    
53.     Next
    
54.     ReDim crr(1 To d.Count, 1 To ls)
    
55.     m = 0
    
56.     For Each aa In d.keys
    
57.         brr = d(aa)
    
58.         m = m + 1
    
59.         For j = 1 To UBound(brr)
    
60.             crr(m, j) = brr(j)
    
61.         Next
    
62.     Next
    
63. 
    
64.     With Worksheets("教师课程总表")
    
65.         .Cells.Clear
    
66.         Worksheets("汇总").Range("a3").Resize(2, c).Copy .Range("a3")
    
67.         .Range("a5").Resize(UBound(crr), UBound(crr, 2)) = crr
    
68.         With .Range("a3").Resize(2 + UBound(crr), UBound(crr, 2))
    
69.             .Borders.LineStyle = xlContinuous
    
70.             With .Font
    
71.                 .Name = "微软雅黑"
    
72.                 .Size = 11
    
73.             End With
    
74.             .HorizontalAlignment = xlCenter
    
75.             .VerticalAlignment = xlCenter
    
76.         End With
    
77.         For j = ls To 3 Step -1
    
78.             If Len(.Cells(3, j).Value) = 0 Then
    
79.                 .Cells(3, j - 1).Resize(1, 2).Merge
    
80.             End If
    
81.         Next
    
82.         .Columns(1).Resize(, UBound(crr, 2)).AutoFit
    
83.     End With
    
84. End Sub
    
85. 
    

复制代码

chxw68

直接从汇总表生成。

jx928867128

chxw68 发表于 2023-3-22 10:32
不太好处理，因为汇总表里的数据不太规范。

非常感谢您的再次回贴，再次感谢

jx928867128

chxw68 发表于 2023-3-22 10:44
直接从汇总表生成。

太感谢您了，再次谢谢老师，我把您的代码复制到我工作中需要用的表格中时运行代码，代码会中断，在您的附件中可以正常运行，方便指导出要注意的地方吗

chxw68

修改好了。

jx928867128

chxw68 发表于 2023-3-22 14:39
修改好了。

再次感谢老师的回贴，我复制代码到我实际用的工作表中，代码还是不能运行，光标在代码第四行卡住了，提示和开始一样的提示

chxw68

jx928867128 发表于 2023-3-22 15:37
再次感谢老师的回贴，我复制代码到我实际用的工作表中，代码还是不能运行，光标在代码第四行卡住了，提示 ...

把那一行删除。