如何根据原始表关键列年级和班级生成各班名册30行分列及各类别人数

yzyyyyyyy

原始表：关键列，年级，班级。性别，政治面貌。

目标表：每个年级，每个班1页，默认不超过60人。行数30，超过分栏。各类人数统计。 如何根据原始表关键列年级和班级生成各班名册30行分列及各类别人数.rar (10.53 KB, 下载次数: 8)

2023-7-3 17:34 上传

点击文件名下载附件

shiruiqiang

修改完成，vba+函数计算

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False
   
7.     Set d = CreateObject("scripting.dictionary")
   
8.     With Worksheets("原始表")
   
9.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
10.         arr = .Range("a2:i" & r)
    
11.     End With
    
12.     For i = 1 To UBound(arr)
    
13.         If Not d.exists(arr(i, 1)) Then
    
14.             Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
15.         End If
    
16.         If Not d(arr(i, 1)).exists(arr(i, 2)) Then
    
17.             Set d(arr(i, 1))(arr(i, 2)) = CreateObject("scripting.dictionary")
    
18.         End If
    
19.         d(arr(i, 1))(arr(i, 2))(i) = Empty
    
20.     Next
    
21.     With Worksheets("目标表")
    
22.         .Cells.Clear
    
23.         r = 1
    
24.         For Each aa In d.keys
    
25.             For Each bb In d(aa).keys
    
26.                 ReDim brr(1 To 30, 1 To 10)
    
27.                 m = 1
    
28.                 n = 1
    
29.                 nan = 0
    
30.                 nu = 0
    
31.                 ty = 0
    
32.                 For Each cc In d(aa)(bb).keys
    
33.                     brr(m, n) = arr(cc, 3)
    
34.                     brr(m, n + 1) = arr(cc, 4)
    
35.                     brr(m, n + 2) = arr(cc, 5)
    
36.                     brr(m, n + 3) = arr(cc, 6)
    
37.                     m = m + 1
    
38.                     If m > 30 Then
    
39.                         m = 1
    
40.                         n = 6
    
41.                     End If
    
42.                     If arr(cc, 5) = "男" Then
    
43.                         nan = nan + 1
    
44.                     Else
    
45.                         nu = nu + 1
    
46.                     End If
    
47.                     If arr(cc, 6) = "团员" Then
    
48.                         ty = ty + 1
    
49.                     End If
    
50.                 Next
    
51.                 With .Cells(r, 1)
    
52.                     .Value = aa & bb & "班名单"
    
53.                     .Resize(1, 10).Merge
    
54.                     With .Font
    
55.                         .Name = "微软雅黑"
    
56.                         .Size = 16
    
57.                     End With
    
58.                 End With
    
59.                 With .Cells(r + 1, 1)
    
60.                     .Value = "班主任：" & Space(6) & "人数" & d(aa)(bb).Count & "人，男" & nan & "人，女" & nu & "人，团员" & ty & "人"
    
61.                     .Resize(1, 10).Merge
    
62.                 End With
    
63.                 .Cells(r + 2, 1).Resize(1, 10) = Array("序号", "姓名", "性别", "政治面貌", "备注", "序号", "姓名", "性别", "政治面貌", "备注")
    
64.                 .Cells(r + 3, 1).Resize(UBound(brr), UBound(brr, 2)) = brr
    
65.                 With .Cells(r + 2, 1).Resize(1 + UBound(brr), 5)
    
66.                     .Borders.LineStyle = xlContinuous
    
67.                     .BorderAround LineStyle:=xlDouble, Weight:=xlThick
    
68.                 End With
    
69.                 With .Cells(r + 2, 6).Resize(1 + UBound(brr), 5)
    
70.                     .Borders.LineStyle = xlContinuous
    
71.                     .BorderAround LineStyle:=xlDouble, Weight:=xlThick
    
72.                 End With
    
73.                 .Rows(r).RowHeight = 30
    
74.                 .Rows(r + 1).Resize(2 + UBound(brr)).RowHeight = 18
    
75.                 r = r + 2 + UBound(brr) + 1
    
76.             Next
    
77.         Next
    
78.         With .UsedRange
    
79.             .HorizontalAlignment = xlCenter
    
80.             .VerticalAlignment = xlCenter
    
81.         End With
    
82.     End With
    
83. End Sub
    

复制代码

chxw68

参与一下。

gwjkkkkk

请参考附件。。。

shiruiqiang

褚老师的三级字典继续学习一下