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

yzyyyyyyy

原始表：关键列班级，姓名

目标表：班级，姓名，人数 如何根据原始表关键列班级姓名生成目标表.rar (10.97 KB, 下载次数: 12)

2024-10-30 16:01 上传

点击文件名下载附件

acbczhhw

=TRANSPOSE(SORT(FILTER(原始表!$E:$E,原始表!$C:$C=目标表1!$A3),,1))

Qs18

1. Sub qs()
   
2. Dim arr, i, dic
   
3. Set dic = CreateObject("scripting.dictionary")
   
4.     arr = Sheet1.[a1].CurrentRegion.Value
   
5.     ReDim brr(1 To UBound(arr), 1 To 100)
   
6. For i = 2 To UBound(arr)
   
7.     s = arr(i, 3)
   
8.     If Not dic.exists(s) Then
   
9.         m = m + 1
   
10.         dic(s) = m
    
11.         brr(m, 1) = s: brr(m, 2) = 1
    
12.         brr(m, 3) = arr(i, 5)
    
13.     Else
    
14.         rw = dic(s)
    
15.         brr(rw, 2) = brr(rw, 2) + 1
    
16.         For j = 4 To 100
    
17.             If brr(rw, j) = Empty Then
    
18.                 brr(rw, j) = arr(i, 5)
    
19.                 If ma <= j Then
    
20.                     ma = j
    
21.                 End If
    
22.             Exit For
    
23.             End If
    
24.         Next
    
25.     End If
    
26. Next
    
27. ReDim crr(1 To 2, 1 To 2)
    
28. crr(1, 1) = "班级": crr(1, 2) = "合计"
    
29. crr(2, 2) = Application.Sum(Application.Index(brr, 0, 2))
    
30. With Sheet2
    
31.     .[a1].Resize(2, 2) = crr
    
32.     .[a3].Resize(m, ma) = brr
    
33. End With
    
34. '目标表2
    
35. ReDim drr(1 To UBound(arr), 1 To 7)
    
36. x = m
    
37. m = 0
    
38. For i = 1 To x
    
39.     m = m + 1
    
40.     drr(m, 1) = brr(i, 1): drr(m, 2) = brr(i, 2)
    
41.     cl = 2
    
42.     For j = 3 To ma
    
43.         If brr(i, j) <> Empty Then
    
44.             cl = cl + 1
    
45.             If j Mod 8 = 0 Then
    
46.                 m = m + 1
    
47.                 cl = 3
    
48.             End If
    
49.             If cl Mod 8 = 0 Then
    
50.    
    
51.                 cl = 3
    
52.             End If
    
53.         drr(m, cl) = brr(i, j)
    
54.         Else
    
55.             Exit For
    
56.         End If
    
57.     Next
    
58. Next
    
59. With Sheet3
    
60.     ReDim Err(1 To 2, 1 To 7)
    
61.     Err(1, 1) = "班级": Err(1, 2) = "人数": Err(1, 3) = "姓名": Err(2, 1) = "合计": Err(2, 2) = crr(2, 2)
    
62.     For i = 1 To 5
    
63.         Err(2, i + 2) = i
    
64.     Next
    
65.     .[a1].Resize(2, 7) = Err
    
66.     .[a3].Resize(m, 7) = drr
    
67. End With
    
68. '目标表3
    
69. Dim frr
    
70. frr = Application.WorksheetFunction.Transpose(brr)
    
71. ReDim grr(1 To ma + 2, 1 To 1)
    
72. grr(1, 1) = "合计": grr(2, 1) = crr(2, 2)
    
73. For i = 1 To ma
    
74.     grr(i + 2, 1) = i
    
75. Next
    
76. With Sheet4
    
77.     [a3].Resize(ma, 1) = grr
    
78.     [b3].Resize(ma, x) = frr
    
79. End With
    
80. 
    
81. Set dic = Nothing
    
82. End Sub
    

复制代码

chxw68

参与练习。

Qs18

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

Qs18

试试.......

Qs18

Sub qs()
Dim arr, i, dic
Set dic = CreateObject("scripting.dictionary")
    arr = Sheet1.[a1].CurrentRegion.Value
    ReDim brr(1 To UBound(arr), 1 To 100)
For i = 2 To UBound(arr)
    s = arr(i, 3)
    If Not dic.exists(s) Then
        m = m + 1
        dic(s) = m
        brr(m, 1) = s: brr(m, 2) = 1
        brr(m, 3) = arr(i, 5)
    Else
        rw = dic(s)
        brr(rw, 2) = brr(rw, 2) + 1
        For j = 4 To 100
            If brr(rw, j) = Empty Then
                brr(rw, j) = arr(i, 5)
                If ma <= j Then
                    ma = j
                End If
            Exit For
            End If
        Next
    End If
Next
ReDim crr(1 To 2, 1 To 2)
crr(1, 1) = "班级": crr(1, 2) = "合计"
crr(2, 2) = Application.Sum(Application.Index(brr, 0, 2))
With Sheet2
    .[a1].Resize(2, 2) = crr
    .[a3].Resize(m, ma) = brr
End With
'目标表2
ReDim drr(1 To UBound(arr), 1 To 7)
x = m
m = 0
For i = 1 To x
    m = m + 1
    drr(m, 1) = brr(i, 1): drr(m, 2) = brr(i, 2)
    cl = 2
    For j = 3 To ma
        If brr(i, j) <> Empty Then
            cl = cl + 1
            If j Mod 8 = 0 Then
                m = m + 1
                cl = 3
            End If
            If cl Mod 8 = 0 Then
   
                cl = 3
            End If
        drr(m, cl) = brr(i, j)
        Else
            Exit For
        End If
    Next
Next
With Sheet3
    ReDim Err(1 To 2, 1 To 7)
    Err(1, 1) = "班级": Err(1, 2) = "人数": Err(1, 3) = "姓名": Err(2, 1) = "合计": Err(2, 2) = crr(2, 2)
    For i = 1 To 5
        Err(2, i + 2) = i
    Next
    .[a1].Resize(2, 7) = Err
    .[a3].Resize(m, 7) = drr
End With
'目标表3
Dim frr
frr = Application.WorksheetFunction.Transpose(brr)
ReDim grr(1 To ma + 2, 1 To 1)
grr(1, 1) = "合计": grr(2, 1) = crr(2, 2)
For i = 1 To ma
    grr(i + 2, 1) = i
Next
With Sheet4
    .[a3].Resize(ma, 1) = grr
    .[b3].Resize(ma, x) = frr
End With

Set dic = Nothing
End Sub