求助考试三率的计算

熊文来

统计每个校区 每个年级 每个班的三率情况以及每个年级前50名 前51-100名  和每个年级倒数100名和倒数200名学生人数。
谢谢大家的帮忙啊。

一把小刀闯天下

'仅处理了"起点成绩"工作表,其它的看得都头大,自己想点办法吧

'假设A、B、C列为有序

Option Explicit

Sub test()
  Dim arr, pos, i, j, k, temp
  pos = Array(6, 7, 8, 9)
  With Sheets("起点成绩")
    arr = .Range("a2:r" & .Cells(Rows.Count, "c").End(xlUp).Row + 1)
    For i = 1 To UBound(arr, 1) - 1: arr(i, 18) = i: Next
    temp = arr
    For i = 1 To UBound(arr, 1) - 1
      For j = i To UBound(arr, 1) - 1
        If arr(j, 3) <> arr(j + 1, 3) Then
          For k = 0 To UBound(pos)
            Call msort(arr, temp, i, j, pos(k), False)
            Call rank(arr, i, j, pos(k), pos(k) + UBound(pos) + 1)
          Next
          For k = 0 To UBound(pos)
            Call msort(arr, temp, i, j, pos(k), True)
            Call rank(arr, i, j, pos(k), pos(k) + (UBound(pos) + 1) * 2)
          Next
          i = j: Exit For
        End If
    Next j, i
    Call msort(arr, temp, 1, UBound(arr, 1) - 1, 18, True)
    .[a2].Resize(UBound(arr, 1) - 1, UBound(arr, 2)) = arr
  End With
End Sub

Function rank(arr, first, last, key, col) '美式排名
  Dim i, j, m
  m = 1: arr(first, col) = 1
  For i = first + 1 To last
    m = m + 1
    arr(i, col) = IIf(arr(i, key) = arr(i - 1, key), arr(i - 1, col), m)
  Next
End Function

Function msort(arr, temp, first, last, key, order)
  Dim i As Long, j As Long, k As Long, kk As Long, mid As Long
  If first <> last Then
    mid = Int((first + last) / 2)
    msort arr, temp, first, mid, key, order
    msort arr, temp, mid + 1, last, key, order
    i = first: j = mid + 1: k = first
    While i <= mid And j <= last
      If arr(i, key) > arr(j, key) Xor order Then
        For kk = 1 To UBound(arr, 2): temp(k, kk) = arr(i, kk): Next
        k = k + 1: i = i + 1
      Else
        For kk = 1 To UBound(arr, 2): temp(k, kk) = arr(j, kk): Next
        k = k + 1: j = j + 1
      End If
    Wend
    While i <= mid
      For kk = 1 To UBound(arr, 2): temp(k, kk) = arr(i, kk): Next
      k = k + 1: i = i + 1
    Wend
    While j <= last
      For kk = 1 To UBound(arr, 2): temp(k, kk) = arr(j, kk): Next
      k = k + 1: j = j + 1
    Wend
    For i = first To last
      For j = 1 To UBound(arr, 2)
        arr(i, j) = temp(i, j)
    Next j, i
  End If
End Function

熊文来

一把小刀闯天下 发表于 2018-10-25 20:05
'仅处理了"起点成绩"工作表,其它的看得都头大,自己想点办法吧

'假设A、B、C列为有序

大侠 有附件吗？
能发给我吗？谢谢

xhms

成绩分析 横向20181025.zip (639.19 KB, 下载次数: 2)

2018-10-26 10:39 上传

点击文件名下载附件

楼主，你看一下吧！
只是做了一部分。其余部分请楼主，参考前面的修改一下公式相关的内容。
还有，最好是用服务器跑这个表格。还未完成（只是做了其中一部分）就卡了，全部的话，一定是要服务器了。
vba是最好的！

chxw68

这个问题最适合用VBA来实现了，但楼主要求好像是想用公式和函数完成。

熊文来

chxw68 发表于 2018-10-26 11:03
这个问题最适合用VBA来实现了，但楼主要求好像是想用公式和函数完成。

大师 您可以用VBA来帮忙做。谢谢！

熊文来

chxw68 发表于 2018-10-26 11:03
这个问题最适合用VBA来实现了，但楼主要求好像是想用公式和函数完成。

排名按照西式排名 相同分数的排名相同 下一个分数的 跳过重复排名 的名次 往下排。也就是假如有2个学生分数相同 都排在15名 那么下一个分数的学生从17名开始排

谢谢大侠帮我做做

chxw68

排序代码

1. Sub test1()
   
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.   With Worksheets("起点成绩")
   
8.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.     arr = .Range("a2:q" & r)
   
10.     .Range("j2:q" & r).ClearContents
    
11.     For j = 6 To 9
    
12.       d.RemoveAll
    
13.       For i = 1 To UBound(arr)
    
14.         If Len(arr(i, j)) <> 0 Then
    
15.           If Not d.exists(arr(i, 2)) Then
    
16.             Set d(arr(i, 2)) = CreateObject("scripting.dictionary")
    
17.           End If
    
18.           d(arr(i, 2))(arr(i, j)) = d(arr(i, 2))(arr(i, j)) + 1
    
19.         End If
    
20.       Next
    
21.       For Each aa In d.keys
    
22.         nn = 1
    
23.         kk = d(aa).keys
    
24.         For k = 0 To UBound(kk)
    
25.           mm = Application.Large(kk, k + 1)
    
26.           ss = d(aa)(mm)
    
27.           d(aa)(mm) = nn
    
28.           nn = nn + ss
    
29.         Next
    
30.       Next
    
31.       d1.RemoveAll
    
32.       For Each aa In d.keys
    
33.         d1(aa) = Application.Max(d(aa).items)
    
34.       Next
    
35.       tt = d1.items
    
36.       For i = 1 To UBound(arr)
    
37.         If Len(arr(i, j)) <> 0 Then
    
38.           arr(i, j + 4) = d(arr(i, 2))(arr(i, j))
    
39.           arr(i, j + 8) = d1(arr(i, 2)) - arr(i, j + 4) + 1
    
40.         End If
    
41.       Next
    
42.     Next
    
43.     .Range("a2").Resize(UBound(arr), UBound(arr, 2)) = arr
    
44.   End With
    
45. End Sub
    

复制代码

chxw68

详见附件。

chxw68

三率计算

1. Sub test2()
   
2.   Dim r%, i%
   
3.   Dim arr, brr, zrr()
   
4.   Dim d As Object
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   Set d1 = CreateObject("scripting.dictionary")
   
9.   With Worksheets("起点三率计算")
   
10.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
11.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
12.     .Range("d2").Resize(r - 1, c - 3).ClearContents
    
13.     brr = .Range("a2").Resize(r - 1, c)
    
14.     xx = ""
    
15.     m = 0
    
16.     For i = 1 To UBound(brr)
    
17.       xm = brr(i, 1) & "+" & brr(i, 2) & "+" & brr(i, 3)
    
18.       d(xm) = i
    
19.       If brr(i, 1) & "+" & brr(i, 2) <> xx Then
    
20.         m = m + 1
    
21.         ReDim Preserve zrr(1 To 2, 1 To m)
    
22.         zrr(1, m) = i
    
23.         zrr(2, m) = i
    
24.         xx = brr(i, 1) & "+" & brr(i, 2)
    
25.       Else
    
26.         zrr(2, m) = i
    
27.       End If
    
28.     Next
    
29.   End With
    
30.   With Worksheets("起点成绩")
    
31.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
32.     arr = .Range("a2:h" & r)
    
33.   End With
    
34.   For i = 1 To UBound(arr)
    
35.     xm = arr(i, 1) & "+" & arr(i, 2) & "+" & arr(i, 3)
    
36.     If d.exists(xm) Then
    
37.       m = d(xm)
    
38.       For j = 6 To 8
    
39.         n = j * 15 - 86
    
40.         If Len(arr(i, j)) <> 0 Then
    
41.           brr(m, n) = brr(m, n) + 1
    
42.           brr(m, n + 1) = brr(m, n + 1) + arr(i, j)
    
43.           If arr(i, 2) <= 5 Then
    
44.             If arr(i, j) >= 90 Then
    
45.               brr(m, n + 6) = brr(m, n + 6) + 1
    
46.             End If
    
47.             If arr(i, j) >= 60 Then
    
48.               brr(m, n + 11) = brr(m, n + 11) + 1
    
49.             End If
    
50.           Else
    
51.             Select Case j
    
52.               Case 6
    
53.                 If arr(i, 3) Mod 2 = 1 Then
    
54.                   If arr(i, j) >= 85 Then
    
55.                     brr(m, n + 6) = brr(m, n + 6) + 1
    
56.                   End If
    
57.                 Else
    
58.                   If arr(i, j) >= 80 Then
    
59.                     brr(m, n + 6) = brr(m, n + 6) + 1
    
60.                   End If
    
61.                 End If
    
62.                 If arr(i, j) >= 60 Then
    
63.                   brr(m, n + 11) = brr(m, n + 11) + 1
    
64.                 End If
    
65.               Case 7
    
66.                 If arr(i, 3) Mod 2 = 1 Then
    
67.                   If arr(i, j) >= 90 Then
    
68.                     brr(m, n + 6) = brr(m, n + 6) + 1
    
69.                   End If
    
70.                 Else
    
71.                   If arr(i, j) >= 80 Then
    
72.                     brr(m, n + 6) = brr(m, n + 6) + 1
    
73.                   End If
    
74.                 End If
    
75.                 If arr(i, j) >= 60 Then
    
76.                   brr(m, n + 11) = brr(m, n + 11) + 1
    
77.                 End If
    
78.               Case 8
    
79.                 If arr(i, 3) Mod 2 = 1 Then
    
80.                   If arr(i, j) >= 27 Then
    
81.                     brr(m, n + 6) = brr(m, n + 6) + 1
    
82.                   End If
    
83.                 Else
    
84.                   If arr(i, j) >= 24 Then
    
85.                     brr(m, n + 6) = brr(m, n + 6) + 1
    
86.                   End If
    
87.                 End If
    
88.                 If arr(i, j) >= 18 Then
    
89.                   brr(m, n + 11) = brr(m, n + 11) + 1
    
90.                 End If
    
91.             End Select
    
92.           End If
    
93.         End If
    
94.       Next
    
95.     End If
    
96.   Next
    
97.   For q = 1 To UBound(zrr, 2)
    
98.     ReDim crr(1 To UBound(brr, 2))
    
99.     For i = zrr(1, q) To zrr(2, q)
    
100.       For j = 4 To UBound(brr, 2)
     
101.         crr(j) = crr(j) + brr(i, j)
     
102.       Next
     
103.     Next
     
104.     For j = 4 To UBound(brr, 2) Step 15
     
105.       If Len(crr(j)) <> 0 And crr(j) <> 0 Then
     
106.         crr(j + 1) = Round(crr(j + 1) / crr(j), 2)
     
107.         crr(j + 6) = Round(crr(j + 6) / crr(j), 4)
     
108.         crr(j + 11) = Round(crr(j + 11) / crr(j), 4)
     
109.       End If
     
110.     Next
     
111.     For i = zrr(1, q) To zrr(2, q)
     
112.       For j = 4 To UBound(brr, 2) Step 15
     
113.         If Len(brr(i, j)) <> 0 And brr(i, j) <> 0 Then
     
114.           brr(i, j + 1) = Round(brr(i, j + 1) / brr(i, j), 2)
     
115.           brr(i, j + 6) = Round(brr(i, j + 6) / brr(i, j), 4)
     
116.           brr(i, j + 11) = Round(brr(i, j + 11) / brr(i, j), 4)
     
117.         End If
     
118.       Next
     
119.     Next
     
120.     For i = zrr(1, q) To zrr(2, q)
     
121.       For j = 4 To UBound(brr, 2) Step 15
     
122.         brr(i, j) = crr(j + 1)
     
123.         brr(i, j + 5) = crr(j + 6)
     
124.         brr(i, j + 10) = crr(j + 11)
     
125.         brr(i, j + 2) = Round(brr(i, j + 1) - brr(i, j), 2)
     
126.         brr(i, j + 7) = Round(brr(i, j + 6) - brr(i, j + 5), 2)
     
127.         brr(i, j + 12) = Round(brr(i, j + 11) - brr(i, j + 10), 2)
     
128.       Next
     
129.     Next
     
130.     For j = 4 To UBound(brr, 2) Step 15
     
131.       For y = 2 To 12 Step 5
     
132.         d1.RemoveAll
     
133.         If brr(zrr(1, q), 2) < 5 Then
     
134.           For i = zrr(1, q) To zrr(2, q)
     
135.             If Len(brr(i, j + y)) <> 0 Then
     
136.               d1(brr(i, j + y)) = d1(brr(i, j + y)) + 1
     
137.             End If
     
138.           Next
     
139.           nn = 1
     
140.           kk = d1.keys
     
141.           For k = 0 To UBound(kk)
     
142.             mm = Application.Large(kk, k + 1)
     
143.             ss = d1(mm)
     
144.             d1(mm) = nn
     
145.             nn = nn + ss
     
146.           Next
     
147.           For i = zrr(1, q) To zrr(2, q)
     
148.             If Len(brr(i, j + y)) <> 0 Then
     
149.               brr(i, j + y + 1) = d1(brr(i, j + y))
     
150.               brr(i, j + y + 2) = zrr(2, q) - zrr(1, q) + 2 - brr(i, j + y + 1)
     
151.             End If
     
152.           Next
     
153.         Else
     
154.           For i = zrr(1, q) To zrr(2, q)
     
155.             If Len(brr(i, j + y)) <> 0 Then
     
156.               w = brr(i, 2) Mod 2
     
157.               If Not d1.exists(w) Then
     
158.                 Set d1(w) = CreateObject("scripting.dictionary")
     
159.               End If
     
160.               d1(w)(brr(i, j + y)) = d1(w)(brr(i, j + y)) + 1
     
161.             End If
     
162.           Next
     
163.           For Each bb In d1.keys
     
164.             nn = 1
     
165.             kk = d1(bb).keys
     
166.             For k = 0 To UBound(kk)
     
167.               mm = Application.Large(kk, k + 1)
     
168.               ss = d1(bb)(mm)
     
169.               d1(bb)(mm) = nn
     
170.               nn = nn + ss
     
171.             Next
     
172.           Next
     
173.           For i = zrr(1, q) To zrr(2, q)
     
174.             If Len(brr(i, j + y)) <> 0 Then
     
175.               w = brr(i, 2) Mod 2
     
176.               brr(i, j + y + 1) = d1(w)(brr(i, j + y))
     
177.             End If
     
178.           Next
     
179.         End If
     
180.       Next
     
181.     Next
     
182.   Next
     
183.   With Worksheets("起点三率计算")
     
184.     .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
     
185.   End With
     
186. End Sub
     

复制代码