初一年成绩分析

chxw68

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

复制代码

chxw68

科分析的代码写好了。其他的代码抽时间再改写吧。

chxw68

全部写完了，没有时间认真校对，肯定还有不少问题，尽量抽空修改吧。

NA2105

chxw68 发表于 2023-3-31 09:45
全部写完了，没有时间认真校对，肯定还有不少问题，尽量抽空修改吧。

感谢老师在百忙之中，抽出时间，感恩。

全党

chxw68 发表于 2023-3-30 22:08
科分析的代码写好了。其他的代码抽时间再改写吧。

优秀作品，无私奉献，值得尊敬！

NA2105

chxw68 发表于 2023-3-31 09:45
全部写完了，没有时间认真校对，肯定还有不少问题，尽量抽空修改吧。

老师您好，测试如下，分科统计显示下标越界，及格差显示类型不匹配，全科及格率没有统计结果，还有总分这样也没有统计结果 ，科分析工作表没有生成总分项目的各项数据。其他数据均完成。谢谢！

chxw68

NA2105 发表于 2023-3-31 18:03
老师您好，测试如下，分科统计显示下标越界，及格差显示类型不匹配，全科及格率没有统计结果，还有总分这 ...

VBA都是定制的，基本上一事一码，你把原始数据这么大幅度修改，代码运行出错是必然的！建议你最好一次性整理好自己的原始文件和需求，然后再来这里求助。

chxw68

NA2105 发表于 2023-3-31 18:03
老师您好，测试如下，分科统计显示下标越界，及格差显示类型不匹配，全科及格率没有统计结果，还有总分这 ...

最近特别忙，你等别人来帮助你吧，不要等我了。

NA2105

chxw68 发表于 2023-3-31 21:55
最近特别忙，你等别人来帮助你吧，不要等我了。

知道的，谢谢老师！

NA2105

chxw68 发表于 2023-3-31 09:45
全部写完了，没有时间认真校对，肯定还有不少问题，尽量抽空修改吧。

老师在吗，那个全科及格率能帮我完善一下吗，其他暂时不用了，谢谢！