VBA成绩统计

ypcf0312

谢谢chxw68大侠的帮助，完成了统计部分功能，请各位大神再帮忙完善一下。谢谢

chxw68

1. Sub test11()
   
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("a6:ay" & r)
   
9.     For i = 1 To UBound(arr)
   
10.       If Not d.exists(arr(i, 2)) Then
    
11.         ReDim brr(1 To 2)
    
12.       Else
    
13.         brr = d(arr(i, 2))
    
14.       End If
    
15.       For j = 3 To 15
    
16.         brr(1) = brr(1) + arr(i, j)
    
17.       Next
    
18.       For j = 16 To 23
    
19.         brr(2) = brr(2) + arr(i, j)
    
20.       Next
    
21.       d(arr(i, 2)) = brr
    
22.     Next
    
23.   End With
    
24.   With Worksheets("统计")
    
25.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
26.     arr = .Range("a6:b" & r)
    
27.     ReDim brr(1 To UBound(arr), 1 To 2)
    
28.     For i = 1 To UBound(arr)
    
29.       If d.exists(arr(i, 2)) Then
    
30.         crr = d(arr(i, 2))
    
31.         brr(i, 1) = crr(1)
    
32.         brr(i, 2) = crr(2)
    
33.       End If
    
34.     Next
    
35.     .Range("c6").Resize(UBound(brr), 2) = brr
    
36.   End With
    
37.         
    
38. End Sub
    

复制代码

chxw68

详见附件。

凌空一羽

1. Sub lkyy113()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. ar = Sheet1.Range("a5").CurrentRegion
   
4. For i = 2 To UBound(ar)
   
5.     For j = 3 To 15
   
6.         d(ar(i, 1)) = d(ar(i, 1)) + ar(i, j)
   
7.     Next
   
8. Next
   
9. m = Range("a5").End(4).Row
   
10. For i = 6 To m
    
11.     t = Cells(i, 1).Text
    
12.     If d.exists(t) Then Cells(i, 3) = d(t)
    
13. Next
    
14. Set d = Nothing
    
15. End Sub
    
16. 
    
17. Sub lkyy1421()
    
18. Set d = CreateObject("Scripting.Dictionary")
    
19. ar = Sheet1.Range("a5").CurrentRegion
    
20. For i = 2 To UBound(ar)
    
21.     For j = 16 To 23
    
22.         d(ar(i, 1)) = d(ar(i, 1)) + ar(i, j)
    
23.     Next
    
24. Next
    
25. m = Range("a5").End(4).Row
    
26. For i = 6 To m
    
27.     t = Cells(i, 1).Text
    
28.     If d.exists(t) Then Cells(i, 4) = d(t)
    
29. Next
    
30. Set d = Nothing
    
31. End Sub

复制代码

ypcf0312

谢谢chxw68大侠和凌空一羽大侠的帮助，只是新人级别不到，无法送花，多多包涵。