如何根据原始表关键列班级姓名标记生成目标表名单20240408

yzyyyyyyy

原始表：关键列，班级，姓名，标志，组长。数据乱序。

目标表：标志列中各种值包括空。
以班级为序分别列出姓名；
组长单列；
姓名中组长在第一个；
每行列出4人，超出4人分行；
各班人数小计；
总数合计；
标题含标志和人数。 如何根据原始表关键列班级姓名标记生成目标表名单20240408.rar (2.93 KB, 下载次数: 15)

2024-4-8 08:59 上传

点击文件名下载附件

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("原始表")
   
7.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.         arr = .Range("a2:d" & r)
   
9.     End With
   
10.     For i = 1 To UBound(arr)
    
11.         If Not d.exists(arr(i, 3)) Then
    
12.             Set d(arr(i, 3)) = CreateObject("scripting.dictionary")
    
13.         End If
    
14.         If Not d(arr(i, 3)).exists(arr(i, 1)) Then
    
15.             m = 1
    
16.             ReDim brr(1 To 2, 1 To m)
    
17.         Else
    
18.             brr = d(arr(i, 3))(arr(i, 1))
    
19.             m = UBound(brr, 2) + 1
    
20.             ReDim Preserve brr(1 To 2, 1 To m)
    
21.         End If
    
22.         brr(1, m) = arr(i, 2)
    
23.         brr(2, m) = IIf(arr(i, 4) = "组长", 0, 1)
    
24.         d(arr(i, 3))(arr(i, 1)) = brr
    
25.     Next
    
26.     With Worksheets("目标表")
    
27.         .Cells.Clear
    
28.         r = 1
    
29.         For Each aa In d.keys
    
30.             r0 = r
    
31.             r = r + 2
    
32.             With .Cells(r, 1).Resize(1, 7)
    
33.                 .Value = Array("班级", "人数", "组长", "1", "2", "3", "4")
    
34.                 .Borders.LineStyle = xlContinuous
    
35.             End With
    
36.             r = r + 1
    
37.             .Cells(r, 1) = "合计"
    
38.             With .Cells(r, 1).Resize(1, 7)
    
39.                 .Borders.LineStyle = xlContinuous
    
40.             End With
    
41.             r = r + 1
    
42.             rs = 0
    
43.             For q = Application.Min(d(aa).keys) To Application.Max(d(aa).keys)
    
44.                 If d(aa).exists(q) Then
    
45.                     bb = q
    
46.                     brr = d(aa)(bb)
    
47.                     rs = rs + UBound(brr, 2)
    
48.                     .Cells(r, 1) = bb
    
49.                     .Cells(r, 2) = UBound(brr, 2)
    
50.                     For x = 1 To UBound(brr, 2) - 1
    
51.                         p = x
    
52.                         For y = x + 1 To UBound(brr, 2)
    
53.                             If brr(2, p) > brr(2, y) Then
    
54.                                 p = y
    
55.                             End If
    
56.                         Next
    
57.                         If p <> x Then
    
58.                             For k = 1 To 2
    
59.                                 temp = brr(k, x)
    
60.                                 brr(k, x) = brr(k, p)
    
61.                                 brr(k, p) = temp
    
62.                             Next
    
63.                         End If
    
64.                     Next
    
65.                     If brr(2, 1) = 0 Then
    
66.                         .Cells(r, 3) = brr(1, 1)
    
67.                     End If
    
68.                     hs = Application.Ceiling(UBound(brr, 2) / 4, 1)
    
69.                     ReDim crr(1 To hs, 1 To 4)
    
70.                     m = 1
    
71.                     n = 1
    
72.                     For j = 1 To UBound(brr, 2)
    
73.                         crr(m, n) = brr(1, j)
    
74.                         n = n + 1
    
75.                         If n > 4 Then
    
76.                             n = 1
    
77.                             m = m + 1
    
78.                         End If
    
79.                     Next
    
80.                     With .Cells(r, 4).Resize(UBound(crr), UBound(crr, 2))
    
81.                         .Value = crr
    
82.                     End With
    
83.                     With .Cells(r, 1).Resize(UBound(crr), 7)
    
84.                         .Borders.LineStyle = xlContinuous
    
85.                     End With
    
86.                     r = r + UBound(crr)
    
87.                 End If
    
88.             Next
    
89.             With .Cells(r0, 1)
    
90.                 .Value = "人员名单（标记列为" & aa & "）（共" & rs & "人）"
    
91.                 .Resize(1, 7).Merge
    
92.             End With
    
93.             .Cells(r0 + 3, 2) = rs
    
94.             r = r + 2
    
95.         Next
    
96.         With .UsedRange
    
97.             .HorizontalAlignment = xlCenter
    
98.             .VerticalAlignment = xlCenter
    
99.         End With
    
100.     End With
     
101. 
     
102. 
     
103. End Sub
     

复制代码

chxw68

真为难EXCEL了。

baofa2

参与练习.zip (18.9 KB, 下载次数: 10)

2024-4-8 11:05 上传

点击文件名下载附件

蓝桥玄霜

名单的例子：