汇总与拆分代码求帮忙

chxw68

详见附件。

jx928867128

chxw68 发表于 2023-4-17 16:16
详见附件。

谢谢老师的多次帮忙，后面3个年级的名字不对，正确的名字是政治走班，物理分班， 政治分班（有阿拉伯数字的就提取这个数字前的作为表名，没有阿拉伯数字的，全部名作为表名），分表中的第二行如果没有填写老师，不能删除，从第三行开始，如果没有填写任课老师的就删除行

chxw68

修改好了。

jx928867128

chxw68 发表于 2023-4-17 16:34
修改好了。

非常感谢老师的多次帮忙，再次感谢

jx928867128

chxw68 发表于 2023-4-17 16:34
修改好了。

老师好，物化政多出 了历史学科没有删除

chxw68

汇总表中物化政班级的历史栏有空格，删除就好了。

jx928867128

chxw68 发表于 2023-4-17 17:20
汇总表中物化政班级的历史栏有空格，删除就好了。

再次谢谢您的多次帮忙与指导，这个拆分代码已经很完美了

chxw68

汇总代码：

1. Sub test2()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Dim ws As Worksheet
   
6.     Application.ScreenUpdating = False
   
7.     Application.DisplayAlerts = False
   
8.     Set d = CreateObject("scripting.dictionary")
   
9.     Set d1 = CreateObject("scripting.dictionary")
   
10.     With Worksheets("总表")
    
11.         c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
12.         arr = .Range("a1").Resize(1, c)
    
13.         For j = 2 To UBound(arr, 2)
    
14.             d1(arr(1, j)) = j
    
15.         Next
    
16.     End With
    
17.     For Each ws In Worksheets
    
18.         If ws.Name <> "总表" Then
    
19.             With ws
    
20.                 If .Range("a1") = "课程编号" And .Range("b1") = "课别" Then
    
21.                     r = .Cells(.Rows.Count, 3).End(xlUp).Row
    
22.                     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
23.                     If r > 1 Then
    
24.                         arr = .Range("a1").Resize(r, c)
    
25.                         For j = 11 To UBound(arr, 2) - 4
    
26.                             If Not d.exists(arr(1, j)) Then
    
27.                                 ReDim brr(1 To 21)
    
28.                                 brr(1) = arr(1, j)
    
29.                             Else
    
30.                                 brr = d(arr(i, j))
    
31.                             End If
    
32.                             For i = 2 To UBound(arr)
    
33.                                 If d1.exists(arr(i, 3)) Then
    
34.                                     n = d1(arr(i, 3))
    
35.                                     brr(n) = arr(i, j)
    
36.                                     brr(n + 1) = arr(i, 5)
    
37.                                 End If
    
38.                             Next
    
39.                             d(arr(1, j)) = brr
    
40.                         Next
    
41.                     End If
    
42.                 End If
    
43.             End With
    
44.         End If
    
45.     Next
    
46.     With Worksheets("总表")
    
47.         .UsedRange.Offset(1, 0).Clear
    
48.         With .Range("a2").Resize(d.Count, UBound(brr))
    
49.             .Value = Application.Transpose(Application.Transpose(d.items))
    
50.             .Borders.LineStyle = xlContinuous
    
51.             With .Font
    
52.                 .Name = "微软雅黑"
    
53.                 .Size = 10
    
54.             End With
    
55.         End With
    
56.     End With
    
57. End Sub
    

复制代码

chxw68

增加了汇总的代码。

jx928867128

chxw68 发表于 2023-4-17 19:25
增加了汇总的代码。

再次感谢老师的付出，感谢，祝您生活愉快