求一个分班打印模板代码

17313845

根据“学生信息”表各班级人数平均分列，并调取各班级学生信息到“打印模板”中，班级数太多，学生数量大，复制粘贴太麻烦，求各位大神给个代码。      

lu553178681

不知道是不是符合你的要求

蓝桥玄霜

在Q1：Y30复制一个空白表格作为模板。
录入代码执行即可。

17313845

lu553178681 发表于 2024-10-29 16:04
不知道是不是符合你的要求

你这是公式填写，有用，谢谢

17313845

蓝桥玄霜 发表于 2024-10-29 16:24
在Q1：Y30复制一个空白表格作为模板。
录入代码执行即可。

谢谢，解决问题了

Qs18

1. Sub qs()
   
2. Application.ScreenUpdating = False: Application.DisplayAlerts = False
   
3. Dim arr, i, dic
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. brr = Sheet4.UsedRange.Value
   
6.     For i = 2 To UBound(brr)
   
7.         d2(brr(i, 2)) = "教室" & brr(i, 3) & "      班主任：" & brr(i, 1)
   
8.     Next
   
9. arr = Sheet3.UsedRange.Value
   
10. ReDim a(1 To 27, 1 To 4): ReDim b(1 To 27, 1 To 4)
    
11. rw = 32
    
12. For Each k In d2.keys
    
13.     m = 0: h = 0: n = 0
    
14.    For i = 2 To UBound(arr)
    
15.         If k = arr(i, 1) Then
    
16.             m = m + 1
    
17.             If m Mod 2 Then
    
18.                 n = n + 1
    
19.                 For j = 2 To 5
    
20.                     b(n, j - 1) = arr(i, j)
    
21.                 Next
    
22.             Else
    
23.                 h = h + 1
    
24.                 For j = 2 To 5
    
25.                     a(h, j - 1) = arr(i, j)
    
26.                 Next
    
27.             
    
28.             End If
    
29.         End If
    
30.    Next
    
31.    With Sheet1
    
32.         .[a1].Value = "2024级" & k & "班"
    
33.         .[a2].Value = d2(k)
    
34.         .[a4].Resize(27, 9) = Empty
    
35.         .[a4].Resize(n, 4) = b: .[f4].Resize(h, 4) = a
    
36.         .Rows("1:30").Copy .Range("a" & rw)
    
37.         rw = rw + 32
    
38.    End With
    
39. Next
    
40. Sheet1.Rows("1:31").Delete
    
41. Set d2 = Nothing
    
42. Application.ScreenUpdating = True: Application.DisplayAlerts = True
    
43. End Sub
    

复制代码

Qs18

试试............

Qs18

试试............

Qs18

试试............

17313845

Qs18 发表于 2024-10-29 20:12
试试............

大神牛逼，还统计了各班人数平均分列