如何通过全镇学生成绩明细自动生成各校各校的三率一平？

gdyuanjin

如何通过上图类似的全镇学生成绩表自动生成下图的三率一平表，请大神们帮忙！

zxsea_7426

一套字典下来基本就完成了

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.     Set d1 = CreateObject("scripting.dictionary")
   
9.     With Worksheets("镇成绩统计表")
   
10.         c = .Cells(3, .Columns.Count).End(xlToLeft).Column
    
11.         arr = .Range("a3").Resize(1, c)
    
12.         For j = 4 To UBound(arr, 2)
    
13.             d1(arr(1, j)) = j
    
14.         Next
    
15.     End With
    
16.     ls = c
    
17.     With Worksheets("sheet1")
    
18.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
19.         arr = .Range("a1:g" & r)
    
20.     End With
    
21.     For i = 2 To UBound(arr)
    
22.         If d1.exists(arr(i, 1)) Then
    
23.             n = d1(arr(i, 1))
    
24.             For j = 5 To UBound(arr, 2)
    
25.                 If Len(arr(i, j)) <> 0 Then
    
26.                     If Not d.exists(arr(i, 2)) Then
    
27.                         Set d(arr(i, 2)) = CreateObject("scripting.dictionary")
    
28.                     End If
    
29.                     If Not d(arr(i, 2)).exists(arr(1, j)) Then
    
30.                         ReDim brr(1 To 5, 1 To ls)
    
31.                         brr(1, 1) = arr(i, 2)
    
32.                         brr(1, 2) = arr(1, j)
    
33.                         brr(1, 3) = "平均分"
    
34.                         brr(2, 3) = "优良率"
    
35.                         brr(3, 3) = "及格率"
    
36.                         brr(4, 3) = "低分率"
    
37.                     Else
    
38.                         brr = d(arr(i, 2))(arr(1, j))
    
39.                     End If
    
40.                     brr(1, n) = brr(1, n) + arr(i, j)
    
41.                     brr(5, n) = brr(5, n) + 1
    
42.                     If arr(i, j) >= 80 Then
    
43.                         brr(2, n) = brr(2, n) + 1
    
44.                     End If
    
45.                     If arr(i, j) >= 60 Then
    
46.                         brr(3, n) = brr(3, n) + 1
    
47.                     End If
    
48.                     If arr(i, j) <= 40 Then
    
49.                         brr(4, n) = brr(4, n) + 1
    
50.                     End If
    
51.                     d(arr(i, 2))(arr(1, j)) = brr
    
52.                 End If
    
53.             Next
    
54.         End If
    
55.     Next
    
56.     With Worksheets("镇成绩统计表")
    
57.         .UsedRange.Offset(3, 0).Clear
    
58.         r = 4
    
59.         For Each aa In d.keys
    
60.             r1 = r
    
61.             For Each bb In d(aa).keys
    
62.                 brr = d(aa)(bb)
    
63.                 For i = 1 To 5
    
64.                     For j = 4 To UBound(brr, 2) - 1
    
65.                         brr(i, UBound(brr, 2)) = brr(i, UBound(brr, 2)) + brr(i, j)
    
66.                     Next
    
67.                 Next
    
68.                 For j = 4 To UBound(brr, 2)
    
69.                     If brr(5, j) <> 0 And Len(brr(5, j)) <> 0 Then
    
70.                         brr(1, j) = Application.Round(brr(1, j) / brr(5, j), 2)
    
71.                         brr(2, j) = Application.Round(brr(2, j) / brr(5, j), 4) * 100
    
72.                         brr(3, j) = Application.Round(brr(3, j) / brr(5, j), 4) * 100
    
73.                         brr(4, j) = Application.Round(brr(4, j) / brr(5, j), 4) * 100
    
74.                     End If
    
75.                 Next
    
76.                 .Cells(r, 1).Resize(4, UBound(brr, 2)) = brr
    
77.                 .Cells(r, 2).Resize(4, 1).Merge
    
78.                 r = r + 4
    
79.             Next
    
80.             .Cells(r1, 1).Resize(d(aa).Count * 4, 1).Merge
    
81.         Next
    
82.         With .Range("a3:n" & r - 1)
    
83.             .Borders.LineStyle = xlContinuous
    
84.             With .Font
    
85.                 .Name = "微软雅黑"
    
86.                 .Size = 9
    
87.             End With
    
88.         End With
    
89.         With .UsedRange
    
90.             .HorizontalAlignment = xlCenter
    
91.             .VerticalAlignment = xlCenter
    
92.         End With
    
93.     End With
    
94. End Sub
    

复制代码

chxw68

详见附件。