汇总与拆分代码求帮忙

jx928867128

汇总与拆分.rar (13.92 KB, 下载次数: 12)

2023-4-16 09:09 上传

点击文件名下载附件

chxw68

相同年级的不同班级相同课目使用同一课时，这些课时都一样吗?比如：政历地9、政历地20、政历地21共用一个课时，这三个班课时一样吗?

洋务德雷

好复杂呀，我要是干这个的才能知道要干嘛

jx928867128

chxw68 发表于 2023-4-16 09:48
相同年级的不同班级相同课目使用同一课时，这些课时都一样吗?比如：政历地9、政历地20、政历地21共用一个课 ...

谢谢老师的多次帮忙与回贴，
相同年级的不同班级相同课目使用同一课时，这些课时都一样

shiruiqiang

这个工作量有一点，
首先，正则式生成a列所对应的分表
其次，分表对应a列生成第1行的班级
3、分表提取第一行班主任的姓名，以及分表对应的课程
最后，提取分表对应的任课老师

jx928867128

shiruiqiang 发表于 2023-4-16 12:08
这个工作量有一点，
首先，正则式生成a列所对应的分表
其次，分表对应a列生成第1行的班级

再次谢谢您的关注与回贴

shiruiqiang

根据要求分4步基本完成拆分，有点取巧（就是任课科目没有提取）。代码思路有点长，等论坛老师更好的代码

jx928867128

shiruiqiang 发表于 2023-4-16 19:10
根据要求分4步基本完成拆分，有点取巧（就是任课科目没有提取）。代码思路有点长，等论坛老师更好的代码

非常感谢您的帮忙，再次感谢，任教科目实际工作中经常要改变，如果能自动提取任教科目就更方便了，还有就是各年级表中从第三行开始如果没有任课老师的空行要是能用程序自动删除掉更好

jx928867128

本贴继续求好心人帮忙解决

chxw68

1. Sub test()
   
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.     Set d1 = CreateObject("scripting.dictionary")
   
10.     With reg
    
11.         .Global = False
    
12.         .Pattern = "(.+?)((?:\d+|走|分)班)"
    
13.     End With
    
14.     With Worksheets("总表")
    
15.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
16.         c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
17.         arr = .Range("a1").Resize(r, c)
    
18.     End With
    
19.     ReDim brr(1 To UBound(arr), 1 To 2)
    
20.    
    
21.     For i = 2 To UBound(arr)
    
22.         Set mh = reg.Execute(arr(i, 1))
    
23.         If mh.Count > 0 Then
    
24.             brr(i, 1) = mh(0).SubMatches(0)
    
25.             brr(i, 2) = mh(0).SubMatches(1)
    
26.             If Not d1.exists(brr(i, 1)) Then
    
27.                 Set d1(brr(i, 1)) = CreateObject("scripting.dictionary")
    
28.             End If
    
29.             d1(brr(i, 1))(arr(i, 1)) = Empty
    
30.         End If
    
31.     Next
    
32.     For Each aa In d1.keys
    
33.         n = 10
    
34.         For Each bb In d1(aa).keys
    
35.             n = n + 1
    
36.             d1(aa)(bb) = n
    
37.         Next
    
38.     Next
    
39.     For i = 2 To UBound(arr)
    
40.         For j = 2 To UBound(arr, 2) Step 2
    
41.             If Len(arr(i, j)) <> 0 Then
    
42.                 If Not d.exists(brr(i, 1)) Then
    
43.                     Set d(brr(i, 1)) = CreateObject("scripting.dictionary")
    
44.                 End If
    
45.                 n = d1(brr(i, 1))(arr(i, 1))
    
46.                 If Not d(brr(i, 1)).exists(arr(1, j)) Then
    
47.                     ls = 14 + d1(brr(i, 1)).Count
    
48.                     ReDim crr(1 To ls)
    
49.                     crr(3) = arr(1, j)
    
50.                     crr(5) = arr(i, j + 1)
    
51.                 Else
    
52.                     crr = d(brr(i, 1))(arr(1, j))
    
53.                 End If
    
54.                 crr(n) = arr(i, j)
    
55.                 d(brr(i, 1))(arr(1, j)) = crr
    
56.             End If
    
57.         Next
    
58.     Next
    
59.     For Each aa In d.keys
    
60.         ReDim drr(1 To d(aa).Count, 1 To 14 + d1(aa).Count)
    
61.         m = 0
    
62.         For Each bb In d(aa).keys
    
63.             m = m + 1
    
64.             crr = d(aa)(bb)
    
65.             For j = 1 To UBound(crr)
    
66.                 drr(m, j) = crr(j)
    
67.             Next
    
68.         Next
    
69.         On Error Resume Next
    
70.         Set ws = Worksheets(aa)
    
71.         If Err Then
    
72.             Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
73.             ws.Name = aa
    
74.         End If
    
75.         On Error GoTo 0
    
76.         With ws
    
77.             .Cells.Clear
    
78.             .Range("a1:j1") = Array("课程编号", "课别", "科目", "科目互斥组", "课时", "课节组合", "停课", "阶段", "自动安排场地", "年级组长及备课组长")
    
79.             .Range("k1").Resize(1, d1(aa).Count) = d1(aa).keys
    
80.             .Cells(1, 10 + d1(aa).Count + 1).Resize(1, 4) = Array("教案平齐组", "排课要求_同一天多次处理", "单双周拼合组", "统计标签")
    
81.             .Range("a2").Resize(UBound(drr), UBound(drr, 2)) = drr
    
82.         End With
    
83.     Next
    
84.             
    
85. End Sub
    

复制代码