用数组统计分数段内人数

nl054685

请各位大老帮助修改一下，需现在的模块是分数段内累计，我的要求是要统计各分数段内的人数，不是累计。谢谢！

ykcbf1100

分班级统计吗？

nl054685

ykcbf1100 发表于 2024-2-7 13:43
分班级统计吗？

是的，各班统计各班的人数

ykcbf1100

现在统计的就是各分数段的人数啊，代码应该不用改吧。

fzxba

1. Sub test0() '为何 及格率、优秀率为 100% ？
   
2. 
   
3.   Dim Data, Result(), Dict As Object, strKey As String, ss As String
   
4.   Dim i As Long, j As Long, Cnt As Long, posRow As Long, posCol As Long
   
5.   Dim pas As Double, exc As Double, high As Double, low As Double, Total As Double
   
6.   
   
7.   high = 660
   
8.   low = 600
   
9.   posCol = 13
   
10.   Set Dict = CreateObject("Scripting.Dictionary")
    
11.   Dict.Add "Higher", posCol
    
12.   For i = high - 10 To 600 Step -10
    
13.     posCol = posCol + 1
    
14.     Dict.Add i, posCol
    
15.   Next
    
16. '  For j = i - 10 To low Step -20
    
17. '    posCol = posCol + 1
    
18. '    Dict.Add j, posCol
    
19. '    Dict.Add j + 10, posCol
    
20. '  Next
    
21.   Dict.Add "Lower", posCol + 1
    
22.   ReDim Result(1 To 234, 1 To posCol + 1)
    
23.   
    
24.   Sheet9.Activate
    
25.   If Len(Range("G2").Value) Then exc = Range("G2").Value Else exc = 560
    
26.   If Len(Range("I2").Value) Then pas = Range("I2").Value Else pas = 420
    
27.   
    
28.   Data = Sheet1.Range("A4:L" & Sheet1.Range("A" & Rows.Count).End(xlUp).Row)
    
29.   For i = 1 To UBound(Data)
    
30.     strKey = Trim(Data(i, 1))
    
31.    
    
32.     If Dict.Exists(strKey) Then
    
33.       posRow = Dict(strKey)
    
34.     Else
    
35.       Cnt = Cnt + 1
    
36.       Result(Cnt, 1) = strKey
    
37.       Result(Cnt, 11) = 0
    
38.       Result(Cnt, 12) = 10 ^ 6
    
39.       Dict.Add strKey, Cnt
    
40.       posRow = Cnt
    
41.     End If
    
42.    
    
43. '    If Trim(Data(i, 1)) <> strKey Then  '数据有序时，这快一丁点儿 约 0.01s
    
44. '      Cnt = Cnt + 1
    
45. '      Result(Cnt, 1) = strKey
    
46. '      Result(Cnt, 11) = 0
    
47. '      Result(Cnt, 12) = 10 ^ 6
    
48. '      strKey = Trim(Data(i, 1))
    
49. '      posRow = Cnt
    
50. '    End If
    
51.     Result(posRow, 2) = Result(posRow, 2) + 1
    
52.    
    
53.     If Len(Data(i, 12)) Then
    
54.       Total = Val(Data(i, 12))
    
55.       Result(posRow, 3) = Result(posRow, 3) + 1
    
56.       Result(posRow, 5) = Result(posRow, 5) + Total
    
57.       If Total >= exc Then Result(posRow, 7) = Result(posRow, 7) + 1
    
58.       If Total >= pas Then Result(posRow, 9) = Result(posRow, 9) + 1
    
59.       If Total > Result(posRow, 11) Then Result(posRow, 11) = Total
    
60.       If Total < Result(posRow, 12) Then Result(posRow, 12) = Total
    
61.       If Total < low Then
    
62.         posCol = Dict("Lower")
    
63.         Result(posRow, posCol) = Result(posRow, posCol) + 1
    
64.       Else
    
65.         If Total < high Then j = Dict(Int(Total / 10) * 10) Else j = Dict("Higher")
    
66.         For posCol = j To UBound(Result, 2) - 1
    
67.           Result(posRow, posCol) = Result(posRow, posCol) + 1
    
68.         Next
    
69.       End If
    
70.     End If
    
71.   Next
    
72.   
    
73.   For i = 1 To Cnt
    
74.     For j = 4 To 10 Step 2
    
75.       Result(i, j) = Result(i, j - 1) / Result(i, 3 + (j = 4))
    
76.     Next
    
77.   Next
    
78.   
    
79.   ActiveSheet.UsedRange.Offset(3).ClearContents
    
80.   Range("A4").Resize(Cnt, UBound(Result, 2)) = Result
    
81.   
    
82.   Set Dict = Nothing
    
83.   Beep
    
84. End Sub

复制代码

nl054685

ykcbf1100 发表于 2024-2-7 13:46
现在统计的就是各分数段的人数啊，代码应该不用改吧。

第二段包含着第一段和第二段的，我的要求是各段内的

ykcbf1100

nl054685 发表于 2024-2-7 13:54
第二段包含着第一段和第二段的，我的要求是各段内的

附件供参考。。。

fzxba

未见5楼补充审核中的代码无视改传附件.zip (35.84 KB, 下载次数: 20)

2024-2-7 14:08 上传

点击文件名下载附件

nl054685

ykcbf1100 发表于 2024-2-7 14:06
附件供参考。。。

非常感谢，就是要这个样

nl054685

fzxba 发表于 2024-2-7 14:07

谢谢，我要的就是这个了