如何根据原始表关键列班级性别姓名生成目标表123456

yzyyyyyyy

原始表：班级，性别，性别

目标表：分班级，每行5人折行，人数 如何根据原始表关键列班级性别姓名生成目标表123456.rar (7.3 KB, 下载次数: 20)

2024-9-12 15:44 上传

点击文件名下载附件

chxw68

楼主又有创新呀，以前是三个目标表，现在增加到6个目标表了。

chxw68

只写了目标表1、目标表2、目标表3，后面的不想写了。

yzyyyyyyy

chxw68 发表于 2024-9-13 09:27
只写了目标表1、目标表2、目标表3，后面的不想写了。

感谢大师热心帮助，解决了一大难题。大师若有时间，看一下目标表5和目标表6的统计表，谢谢

chxw68

yzyyyyyyy 发表于 2024-9-13 14:37
感谢大师热心帮助，解决了一大难题。大师若有时间，看一下目标表5和目标表6的统计表，谢谢

目标5和目标6简单，你自己应该会吧？

songshihai

好家伙,一个表要六种统计方式啊,3和4好像是一样一样的哦

yzyyyyyyy

chxw68 发表于 2024-9-13 15:17
目标5和目标6简单，你自己应该会吧？

感谢大师热心帮助，还是大师写

1. Sub test5() '
   
2.   Dim r%, i%, c%, j%, m%, n%
   
3.   Dim arr, brr(1 To 17, 1 To 3)
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   m = 1
   
7.   bj = Sheets("目标表5").Range("A5:A" & Sheets("目标表5").[a65536].End(3).Row)
   
8.   For Each x In bj
   
9.      m = m + 1
   
10.     d(x) = m
    
11.   Next
    
12.   With Worksheets("原始表")
    
13.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
14.         arr = .Range("a2:j" & r)
    
15.     For i = 1 To UBound(arr)
    
16.     If d.Exists(arr(i, 3)) Then '
    
17.         m = d(arr(i, 3))
    
18.         brr(1, 1) = brr(1, 1) + 1
    
19.         brr(m, 1) = brr(m, 1) + 1
    
20.         If arr(i, 6) = "男" Then
    
21.             brr(1, 2) = brr(1, 2) + 1
    
22.             brr(m, 2) = brr(m, 2) + 1
    
23.         Else
    
24.             brr(1, 3) = brr(1, 3) + 1
    
25.             brr(m, 3) = brr(m, 3) + 1
    
26.         End If
    
27.    End If
    
28.   Next
    
29. End With
    
30.   With Worksheets("目标表5") '
    
31.     .Range("B4").Resize(UBound(brr), UBound(brr, 2)) = brr
    
32.   End With
    
33. End Sub
    
34. Sub test6() '
    
35.   Dim r%, i%, c%, j%, m%, n%
    
36.   Dim arr, brr(1 To 17, 1 To 20)
    
37.   Dim d As Object
    
38.   Set d = CreateObject("scripting.dictionary")
    
39.   m = 1
    
40.   'bj = Sheets("目标表6").Range("C3:E3")
    
41.   With Sheets("目标表6")
    
42.         bj = .Range(.Cells(3, 3), .Cells(3, .Cells(3, .Columns.Count).End(xlToLeft).Column))
    
43.    End With
    
44.   For Each x In bj
    
45.      m = m + 1
    
46.     d(x) = m
    
47.   Next
    
48.   With Worksheets("原始表")
    
49.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
50.         arr = .Range("a2:j" & r)
    
51.     For i = 1 To UBound(arr)
    
52.     If d.Exists(arr(i, 3)) Then '
    
53.         m = d(arr(i, 3))
    
54.         brr(1, 1) = brr(1, 1) + 1
    
55.         brr(1, m) = brr(1, m) + 1
    
56.         If arr(i, 6) = "男" Then
    
57.             brr(2, 1) = brr(2, 1) + 1
    
58.             brr(2, m) = brr(2, m) + 1
    
59.         Else
    
60.             brr(3, 1) = brr(3, 1) + 1
    
61.             brr(3, m) = brr(3, m) + 1
    
62.         End If
    
63.    End If
    
64.   Next
    
65. End With
    
66.   With Worksheets("目标表6") '
    
67.     .Range("B4").Resize(UBound(brr), UBound(brr, 2)) = brr
    
68.   End With
    
69. End Sub
    

复制代码

chxw68

yzyyyyyyy 发表于 2024-9-13 17:44
感谢大师热心帮助，还是大师写

不动手永远都不会！