利用VBA将成绩表录入汇总表自动统计出各班各科的成绩情况.

xyxcc177

如果这样可以的话可给你提供插件

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Application.ScreenUpdating = False
   
6.   Application.ScreenUpdating = False
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   Set d1 = CreateObject("scripting.dictionary")
   
9.   With Worksheets("成绩录入表")
   
10.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
11.     arr = .Range("a3:q" & r)
    
12.   End With
    
13.   For j = 7 To 13 Step 2
    
14.     d.RemoveAll
    
15.     d1.RemoveAll
    
16.     sht = Left(arr(1, j), 2) & "统计"
    
17.     With Worksheets(sht)
    
18.       r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
19.       .Range("h5:u" & r).ClearContents
    
20.       brr = .Range("a5:v" & r)
    
21.       For i = 1 To UBound(brr)
    
22.         If brr(i, 1) Like "*班" Then
    
23.           bj = Val(brr(i, 1))
    
24.           d(bj) = i
    
25.         End If
    
26.       Next
    
27.     End With
    
28.     For i = 2 To UBound(arr)
    
29.       bj = Val(Split(arr(i, 3), "（")(1))
    
30.       If d.exists(bj) Then
    
31.         m = d(bj)
    
32.         brr(m, 8) = brr(m, 8) + 1
    
33.         If IsNumeric(arr(i, j)) Then
    
34.           brr(m, 9) = brr(m, 9) + 1
    
35.           brr(m, 10) = brr(m, 10) + arr(i, j)
    
36.           If arr(i, j) >= 60 Then
    
37.             brr(m, 16) = brr(m, 16) + 1
    
38.           End If
    
39.           If arr(i, j) >= 80 Then
    
40.             brr(m, 18) = brr(m, 18) + 1
    
41.           End If
    
42.           If IsEmpty(brr(m, 20)) Then
    
43.             brr(m, 20) = arr(i, j)
    
44.           Else
    
45.             If brr(m, 20) < arr(i, j) Then
    
46.               brr(m, 20) = arr(i, j)
    
47.             End If
    
48.           End If
    
49.           If IsEmpty(brr(m, 21)) Then
    
50.             brr(m, 21) = arr(i, j)
    
51.           Else
    
52.             If brr(m, 21) > arr(i, j) Then
    
53.               brr(m, 21) = arr(i, j)
    
54.             End If
    
55.           End If
    
56.         End If
    
57.       End If
    
58.     Next
    
59.     For Each y In Array(8, 9, 10, 16, 18)
    
60.       For i = 1 To UBound(brr) - 1
    
61.         brr(UBound(brr), y) = brr(UBound(brr), y) + brr(i, y)
    
62.       Next
    
63.     Next
    
64.     brr(UBound(brr), 20) = Application.Max(Application.Index(brr, 0, 20))
    
65.     brr(UBound(brr), 21) = Application.Min(Application.Index(brr, 0, 21))
    
66.     For i = 1 To UBound(brr)
    
67.       If Len(brr(i, 9)) <> 0 And brr(i, 9) <> 0 Then
    
68.         brr(i, 11) = Round(brr(i, 10) / brr(i, 9), 2)
    
69.         brr(i, 17) = Round(brr(i, 16) / brr(i, 9), 2)
    
70.         brr(i, 19) = Round(brr(i, 18) / brr(i, 9), 2)
    
71.       End If
    
72.     Next
    
73.     For i = 1 To UBound(brr) - 1
    
74.       If Len(brr(i, 1)) <> 0 Then
    
75.         brr(i, 12) = brr(i, 11) - brr(UBound(brr), 11)
    
76.         d1(brr(i, 11)) = d1(brr(i, 11)) + 1
    
77.       End If
    
78.     Next
    
79.     kk = d1.keys
    
80.     nn = 1
    
81.     For k = 0 To UBound(kk)
    
82.       mm = Application.Large(kk, k + 1)
    
83.       ss = d1(mm)
    
84.       d1(mm) = nn
    
85.       nn = nn + ss
    
86.     Next
    
87.     For i = 1 To UBound(brr) - 1
    
88.       If Len(brr(i, 1)) <> 0 Then
    
89.         brr(i, 13) = d1(brr(i, 11))
    
90.         brr(i, 14) = brr(i, 7) - brr(i, 13)
    
91.         brr(i, 15) = brr(i, 12) - brr(i, 6)
    
92.       End If
    
93.     Next
    
94.     With Worksheets(sht)
    
95.       .Range("a5").Resize(UBound(brr), UBound(brr, 2)) = brr
    
96.     End With
    
97.   Next
    
98.   Application.ScreenUpdating = True
    
99.   MsgBox "成绩统计完毕！"
    
100. End Sub
     

复制代码

chxw68

呵呵，楼主态度诚恳，写一个代码供参考。

yiran7810

chxw68 发表于 2019-4-18 08:51
同一个问题开新贴是对前面提供帮助老师劳动成果的不认可和不重视，没有特殊情况尽量不要这么做。

谢谢老师的提醒。下一次会注意的。谢谢！

yiran7810

chxw68 发表于 2019-4-18 09:36
呵呵，楼主态度诚恳，写一个代码供参考。

感谢老师的帮助。谢谢！

gdwl1218

chxw68 发表于 2019-4-17 08:41
朱荣兴版主不是已经帮你写了吗？

您能给看一下这个帖子吗？