初一年成绩分析

gtbb2002

micch 发表于 2018-12-30 20:12
成绩排名表，实在是写不动了，前三科排名不想写了，没时间了。

感恩MICCH老师的热心帮助

dwgzy

感恩吧，无论付费与否。如果能长久使用更好。

nkgsm

其实，楼主的分析没有必要牛刀杀鸡，顶多搞一个SQL分析，实际上一般的透视和excel的常规分析就够了，我做了个SQL汇总分析，不知道楼主的评价标准是什么比如，我的及格就统一用大于等于60分的标准

chxw68

abc123281 发表于 2018-12-30 22:02
路过参与一下
同意三楼的说法
    打开看了一下楼主上传的附件  褚老师的代码  大约300行

呵呵，付不付费凭直觉就能感觉到，楼主说得也非常清楚：“在褚老师的无偿帮助下“。

chxw68

1. Sub test2()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   Set d1 = CreateObject("scripting.dictionary")
   
7.   Application.ScreenUpdating = False
   
8.   Application.DisplayAlerts = False
   
9.   Call main
   
10.   With Worksheets("录入成绩")
    
11.     r = .Cells(.Rows.Count, 4).End(xlUp).Row
    
12.     arr = .Range("a2:n" & r)
    
13.   End With
    
14.   For j = 5 To UBound(arr, 2) - 1
    
15.     If Application.Count(Application.Index(arr, 0, j)) > 0 Then
    
16.       Set d(arr(1, j)) = CreateObject("scripting.dictionary")
    
17.       jq30 = Application.Large(Application.Index(arr, 0, j), 30)
    
18.       jq60 = Application.Large(Application.Index(arr, 0, j), 60)
    
19.       jh50 = Application.Small(Application.Index(arr, 0, j), 50)
    
20.       
    
21.       For i = 2 To UBound(arr)
    
22.         If Not d(arr(1, j)).exists(arr(i, 2)) Then
    
23.           ReDim brr(1 To 23)
    
24.           brr(1) = arr(i, 2)
    
25.           brr(2) = arr(1, j)
    
26.         Else
    
27.           brr = d(arr(1, j))(arr(i, 2))
    
28.         End If
    
29.         brr(3) = brr(3) + 1
    
30.         If Len(arr(i, j)) <> 0 Then
    
31.           brr(4) = brr(4) + 1
    
32.           brr(5) = brr(5) + arr(i, j)
    
33.           If arr(i, j) >= dcs(arr(1, j))("C") Then
    
34.             brr(7) = brr(7) + 1
    
35.           End If
    
36.           If arr(i, j) >= dcs(arr(1, j))("B") Then
    
37.             brr(10) = brr(10) + 1
    
38.           End If
    
39.           If arr(i, j) >= dcs(arr(1, j))("A") Then
    
40.             brr(13) = brr(13) + 1
    
41.           End If
    
42.           If IsEmpty(brr(16)) Then
    
43.             brr(16) = arr(i, j)
    
44.           Else
    
45.             If brr(16) < arr(i, j) Then
    
46.               brr(16) = arr(i, j)
    
47.             End If
    
48.           End If
    
49.           If IsEmpty(brr(17)) Then
    
50.             brr(17) = arr(i, j)
    
51.           Else
    
52.             If brr(17) > arr(i, j) Then
    
53.               brr(17) = arr(i, j)
    
54.             End If
    
55.           End If
    
56.           If arr(i, j) <= dcs(arr(1, j))("满分") * 0.3 Then
    
57.             brr(18) = brr(18) + 1
    
58.           End If
    
59.           If arr(i, j) >= jq30 Then
    
60.             brr(21) = brr(21) + 1
    
61.           End If
    
62.           If arr(i, j) >= jq60 Then
    
63.             brr(22) = brr(22) + 1
    
64.           End If
    
65.           If arr(i, j) <= jh50 Then
    
66.             brr(23) = brr(23) + 1
    
67.           End If
    
68.         End If
    
69.         d(arr(1, j))(arr(i, 2)) = brr
    
70.       Next
    
71.     End If
    
72.   Next
    
73.   x = 2
    
74.   With Worksheets("科分析")
    
75.     .UsedRange.Offset(1, 0).Clear
    
76.     With .Range("a1")
    
77.       .Value = "各科质量分析"
    
78.       With .Font
    
79.         .Size = 18
    
80.         .Bold = True
    
81.       End With
    
82.     End With
    
83.     For Each aa In d.keys
    
84.       ReDim crr(1 To d(aa).Count, 1 To UBound(brr))
    
85.       ReDim drr(1 To UBound(crr, 2))
    
86.       m = 0
    
87.       For Each bb In d(aa).keys
    
88.         m = m + 1
    
89.         brr = d(aa)(bb)
    
90.         For j = 1 To UBound(brr)
    
91.           crr(m, j) = brr(j)
    
92.         Next
    
93.         For Each y In Array(3, 4, 5, 7, 10, 13, 18, 21, 22, 23)
    
94.           drr(y) = drr(y) + brr(y)
    
95.         Next
    
96.       Next
    
97.       For i = 1 To UBound(crr)
    
98.         If Len(crr(i, 4)) <> 0 And crr(i, 4) <> 0 Then
    
99.           crr(i, 5) = Round(crr(i, 5) / crr(i, 4), 2)
    
100.           crr(i, 8) = Round(crr(i, 7) / crr(i, 4), 4)
     
101.           crr(i, 11) = Round(crr(i, 10) / crr(i, 4), 4)
     
102.           crr(i, 14) = Round(crr(i, 13) / crr(i, 4), 4)
     
103.           crr(i, 19) = Round(crr(i, 18) / crr(i, 4), 4)
     
104.         End If
     
105.       Next
     
106.       For Each y In Array(5, 8, 11, 14)
     
107.         d1.RemoveAll
     
108.         For i = 1 To UBound(crr)
     
109.           If Len(crr(i, y)) <> 0 Then
     
110.             d1(crr(i, y)) = d1(crr(i, y)) + 1
     
111.           End If
     
112.         Next
     
113.         nn = 1
     
114.         kk = d1.keys
     
115.         For k = 0 To UBound(kk)
     
116.           mm = Application.Large(kk, k + 1)
     
117.           ss = d1(mm)
     
118.           d1(mm) = nn
     
119.           nn = nn + ss
     
120.         Next
     
121.         For i = 1 To UBound(crr)
     
122.           If Len(crr(i, y)) <> 0 Then
     
123.             crr(i, y + 1) = d1(crr(i, y))
     
124.           End If
     
125.         Next
     
126.       Next
     
127.       
     
128.       drr(1) = "合计"
     
129.       drr(2) = crr(1, 2)
     
130.       drr(16) = Application.Max(Application.Index(crr, 0, 16))
     
131.       drr(17) = Application.Min(Application.Index(crr, 0, 17))
     
132.       If Len(drr(4)) <> 0 And drr(4) <> 0 Then
     
133.         drr(5) = Round(drr(5) / drr(4), 2)
     
134.         drr(8) = Round(drr(7) / drr(4), 4)
     
135.         drr(11) = Round(drr(10) / drr(4), 4)
     
136.         drr(14) = Round(drr(13) / drr(4), 4)
     
137.         drr(19) = Round(drr(18) / drr(4), 4)
     
138.       End If
     
139.       
     
140.       For i = 1 To UBound(crr)
     
141.         crr(i, 20) = crr(i, 5) - drr(5)
     
142.       Next
     
143.       
     
144.       .Cells(x, 1).Resize(1, 23) = Array("班级", "科目", "应考" & vbLf & "人数", "实考" & vbLf & "人数", "平均" & vbLf & "分", "名" & vbLf & "次", "及格" & vbLf & "人数", "及格" & vbLf & "率", "名" & vbLf & "次", "良好" & vbLf & "人数", "良好" & vbLf & "率", "名" & vbLf & "次", "A" & vbLf & "人数", "A率", "名" & vbLf & "次", "最高" & vbLf & "分", "最低" & vbLf & "分", "低分" & vbLf & "人数", "低分" & vbLf & "率", "平均" & vbLf & "相对" & vbLf & "分", "级前" & vbLf & "30名" & vbLf & "(人)", "级前" & vbLf & "60名" & vbLf & "(人)", "级后" & vbLf & "50名" & vbLf & "(人)")
     
145.       .Cells(x + 1, 1).Resize(1, UBound(drr)) = drr
     
146.       .Cells(x + 2, 1).Resize(UBound(crr), UBound(crr, 2)) = crr
     
147.       With .Cells(x, 1).Resize(UBound(brr) + 2, 23)
     
148.         .Borders.LineStyle = xlContinuous
     
149.       End With
     
150.       x = x + UBound(crr) + 3
     
151.     Next
     
152.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
     
153.     With .Range("a2:w" & r)
     
154.       With .Font
     
155.         .Size = 10
     
156.       End With
     
157.     End With
     
158.     .Range("h:h,k:k,n:n,s:s").NumberFormatLocal = "0.00%"
     
159.     .Columns("a:w").AutoFit
     
160.     With .UsedRange
     
161.       .HorizontalAlignment = xlCenter
     
162.       .VerticalAlignment = xlCenter
     
163.     End With
     
164.   End With
     
165. End Sub
     

复制代码

chxw68

写了科分析代码。

vvw123

褚老师v5，论坛因你而精彩！

chxw68

vvw123 发表于 2019-1-2 12:20
褚老师v5，论坛因你而精彩！

呵呵，过奖了。

gtbb2002

chxw68 发表于 2019-1-2 10:58
写了科分析代码。

褚老师，您辛苦了，感恩您的付出，论坛真的因你而精彩。再一次拜谢了

gtbb2002

chxw68 发表于 2019-1-2 10:58
写了科分析代码。

褚老师，您好，哪句话是写那个优良率的，那个优良率是大于等满分*0.8，现在像是跟应考人数一样的。