根据总表和班主任表生成班级表

3190496160

hjd528 发表于 2024-2-2 14:16
谢谢朱老师，还有一个问题，就是总表中的最后行在每个班级中都出现，还得麻烦您看一看。

啥意思？不明白哟
你是出现还是需要不出现？
最后几行？
论坛是做义务的，一次性把自己的需求描述清楚很重要，不要挤牙膏似的提问

hjd528

3190496160 发表于 2024-2-2 14:25
啥意思？不明白哟
你是出现还是需要不出现？
最后几行？

总表中最后一行不对，应该903班的，结果每个班级都出现了。

3190496160

hjd528 发表于 2024-2-2 14:28
总表中最后一行不对，应该903班的，结果每个班级都出现了。

呵呵呵，你确定使用我最后给你的附件来测试吗？？？？？
应该不是吧？
反复看了很多遍，最新的附件是没有出现你说的情况的

hjd528

3190496160 发表于 2024-2-2 14:39
呵呵呵，你确定使用我最后给你的附件来测试吗？？？？？
应该不是吧？
反复看了很多遍，最新的附件是没 ...

谢谢！麻烦你了。我找到了原因了，修改一下就可以了。

ykcbf1100

2级字典

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.2.2
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim arr, brr, d
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set d1 = CreateObject("Scripting.Dictionary")
   
7.     Dim tm: tm = Timer
   
8.     For Each sht In Sheets
   
9.         If sht.Name <> "模板" And sht.Name <> "总表" And sht.Name <> "班主任" Then
   
10.             sht.Delete
    
11.         End If
    
12.     Next
    
13.     arr = Sheets("班主任").UsedRange
    
14.     For i = 2 To UBound(arr)
    
15.         s = arr(i, 1)
    
16.         d1(s) = arr(i, 2)
    
17.     Next
    
18.     arr = Sheets("总表").UsedRange
    
19.     For i = 3 To UBound(arr)
    
20.         s = arr(i, 3)
    
21.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
22.         d(s)(i) = i
    
23.     Next
    
24.     b = [{1,2,4,5,6,7,8,9,10}]
    
25.     For Each k In d.keys
    
26.         If k <> Empty Then
    
27.             Sheets("模板").Copy after:=Sheets(Sheets.Count)
    
28.             Set sht = Sheets(Sheets.Count)
    
29.             m = 0
    
30.             ReDim brr(1 To 100, 1 To 9)
    
31.             With sht
    
32.                 .Name = k
    
33.                 .[b2] = k: .[i2] = d1(k)
    
34.                 For Each kk In d(k).keys
    
35.                     m = m + 1
    
36.                     brr(m, 1) = m
    
37.                     For j = 2 To UBound(b)
    
38.                         brr(m, j) = arr(kk, b(j))
    
39.                     Next
    
40.                 Next
    
41.                 .[a4].Resize(m, 9) = brr
    
42.                 .UsedRange.Offset(m + 3).Clear
    
43.             End With
    
44.         End If
    
45.     Next
    
46.     Sheets("总表").Activate
    
47.     Application.ScreenUpdating = False
    
48.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
49. End Sub
    

复制代码

hjd528

ykcbf1100 发表于 2024-2-2 21:31
2级字典

附件供参考。。。

谢谢老师！太给力了！运行很快！