如何分析汇总成绩

蓝桥玄霜

代码只对附件有效，没有通用的代码。

yzyyyyyyy

蓝桥玄霜 发表于 2012-8-1 14:47
代码只对附件有效，没有通用的代码。

感谢版主的再次回复，我的意思是每个学生的编号是唯一固定的，但是这个学生，随着学期的变动，有时班级要调换，姓名有可能改动，但编号不变，这种情况下分析表中显示的班级和姓名是以表12345。。。最后一个表的班级和姓名为准。如果按班级和编号姓名作为关键字的话会出现重复的情况，因为编号一样，但班级和姓名不一样也要作为关键字，请版主给看一下，谢谢了

蓝桥玄霜

1. Sub yy()
   
2. Dim D1 As New Dictionary
   
3. Dim D2 As New Dictionary
   
4. Dim D As New Dictionary
   
5. Dim Arr, i&, x$, Brr, c, a, xx$
   
6. Dim Sht1 As Worksheet, Sht As Worksheet
   
7. Dim k, t, k1, t1, k2, t2, yk, sk, qk, jb, tb
   
8. Sheet1.Activate
   
9. For Each Sht In Sheets
   
10.     If Sht.Name <> "分析" And Sht.Name <> "参数" Then
    
11.         Arr = Sht.[a1].CurrentRegion
    
12.         yk = yk + 1
    
13.         For i = 2 To UBound(Arr)
    
14.             x = Arr(i, 2)
    
15.             D(x) = ""
    
16.             xx = Sht.Name
    
17.             If D1.Exists(x) = False Then Set D1(x) = New Dictionary
    
18.             D1(x)(xx) = Arr(i, 4)  '总分
    
19.             If D2.Exists(x) = False Then Set D2(x) = New Dictionary
    
20.             D2(x)(xx) = Arr(i, 6)  '年排名
    
21.         Next
    
22.     End If
    
23. Next
    
24. k = D.keys
    
25. ReDim Brr(1 To D.Count, 1 To 62)
    
26. 
    
27. For i = 0 To UBound(k)
    
28.     jb = 0: tb = 0
    
29.     Set r1 = Sheets("10").[b:b].Find(k(i), , , 1)
    
30.     If Not r1 Is Nothing Then Brr(i + 1, 1) = Sheets("10").Cells(r1.Row, 1)
    
31.     Brr(i + 1, 2) = k(i)
    
32.     k1 = D1(k(i)).keys: k2 = D2(k(i)).keys
    
33.     t1 = D1(k(i)).items: t2 = D2(k(i)).items
    
34.     sk = UBound(t1) + 1: qk = yk - sk
    
35.     Brr(i + 1, 8) = yk: Brr(i + 1, 9) = sk: Brr(i + 1, 10) = qk
    
36.     For j = 0 To UBound(k1)
    
37.         c = Val(k1(j)) + 46
    
38.         Brr(i + 1, c) = t1(j)
    
39.         Select Case t1(j)
    
40.             Case 555 To 600
    
41.                 Brr(i + 1, 57) = Brr(i + 1, 57) + 1
    
42.             Case 525 To 555
    
43.                 Brr(i + 1, 58) = Brr(i + 1, 58) + 1
    
44.             Case 500 To 525
    
45.                 Brr(i + 1, 59) = Brr(i + 1, 59) + 1
    
46.             Case 480 To 500
    
47.                 Brr(i + 1, 60) = Brr(i + 1, 60) + 1
    
48.             Case 450 To 480
    
49.                 Brr(i + 1, 61) = Brr(i + 1, 61) + 1
    
50.             Case Is < 450
    
51.                 Brr(i + 1, 62) = Brr(i + 1, 62) + 1
    
52.         End Select
    
53.     Next
    
54.     For j = 0 To UBound(k2)
    
55.         c = Val(k2(j)) + 22
    
56.         Brr(i + 1, c) = t2(j)
    
57.         Select Case t2(j)
    
58.             Case 1 To 100
    
59.                 Brr(i + 1, 33) = Brr(i + 1, 33) + 1
    
60.             Case 101 To 150
    
61.                 Brr(i + 1, 34) = Brr(i + 1, 34) + 1
    
62.             Case 151 To 200
    
63.                 Brr(i + 1, 35) = Brr(i + 1, 35) + 1
    
64.             Case 201 To 240
    
65.                 Brr(i + 1, 36) = Brr(i + 1, 36) + 1
    
66.             Case 241 To 320
    
67.                 Brr(i + 1, 37) = Brr(i + 1, 37) + 1
    
68.             Case 321 To 400
    
69.                 Brr(i + 1, 38) = Brr(i + 1, 38) + 1
    
70.             Case 401 To 450
    
71.                 Brr(i + 1, 39) = Brr(i + 1, 39) + 1
    
72.             Case Is > 450
    
73.                 Brr(i + 1, 40) = Brr(i + 1, 40) + 1
    
74.         End Select
    
75.         Select Case t2(j)
    
76.             Case 1 To 160
    
77.                 Brr(i + 1, 41) = Brr(i + 1, 41) + 1
    
78.             Case 161 To 208
    
79.                 Brr(i + 1, 42) = Brr(i + 1, 42) + 1
    
80.             Case 209 To 240
    
81.                 Brr(i + 1, 43) = Brr(i + 1, 43) + 1
    
82.             Case 241 To 320
    
83.                 Brr(i + 1, 44) = Brr(i + 1, 44) + 1
    
84.             Case 321 To 400
    
85.                 Brr(i + 1, 45) = Brr(i + 1, 45) + 1
    
86.             Case Is > 400
    
87.                 Brr(i + 1, 46) = Brr(i + 1, 46) + 1
    
88.         End Select
    
89.     Next
    
90.     For j = 1 To UBound(t2)
    
91.         a = t2(j) - t2(j - 1)
    
92.         If a < 0 Then
    
93.             jb = jb + 1
    
94.             Brr(i + 1, 13 + j) = "↑" & -a
    
95.         Else
    
96.             tb = tb + 1
    
97.             Brr(i + 1, 13 + j) = "↓" & a
    
98.         End If
    
99.     Next
    
100.     Brr(i + 1, 11) = jb
     
101.     Brr(i + 1, 12) = tb
     
102. Next
     
103. [a5].Resize(UBound(Brr), 62) = Brr
     
104. [a5].Resize(UBound(Brr), 62).Sort [AF5], 1
     
105. End Sub
     

复制代码

蓝桥玄霜

请见附件。

yzyyyyyyy

蓝桥玄霜 发表于 2012-8-2 15:58
请见附件。

感谢蓝桥版主的无私的帮助

slywtj123

谢谢分享！很有参考价值！

小蕾丝。

居然没人愿意下载……

lpxkk

谢谢分享！很有价值！

chxw68

居然能把5年前的贴子翻出来，厉害！！！

snnysqqd

太厉害了。谢谢分享！很有参考价值！