一项比较具有挑战性的工作，估计学校上线人数

ckh2004

开学了，学校领导要求对上学期末成绩分析统计，估计中考可能上线人数，手工非常慢，而且每次大考都要做，所以想请老师帮下，谢谢！

chxw68

1. Sub test()
   
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("sheet1")
   
8.     r = .Cells(.Rows.Count, 7).End(xlUp).Row
   
9.     .Range("i2:l" & r).ClearContents
   
10.     brr = .Range("g2:l" & r)
    
11.     For i = 1 To UBound(brr)
    
12.       d(brr(i, 1)) = i
    
13.     Next
    
14.     qsrs = .Range("f1")
    
15.     yxrs = .Range("f2")
    
16.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
17.     .Range("a1:c" & r).Sort key1:=.Range("c2"), order1:=xlDescending, Header:=xlYes
    
18.     arr = .Range("a2:c" & r)
    
19.    
    
20.     For i = 1 To UBound(arr)
    
21.       If Not d1.exists(arr(i, 2)) Then
    
22.         m = 1
    
23.         ReDim crr(1 To 3, 1 To m)
    
24.       Else
    
25.         crr = d1(arr(i, 2))
    
26.         m = UBound(crr, 2) + 1
    
27.         ReDim Preserve crr(1 To 3, 1 To m)
    
28.       End If
    
29.       For j = 1 To 3
    
30.         crr(j, m) = arr(i, j)
    
31.       Next
    
32.       d1(arr(i, 2)) = crr
    
33.     Next
    
34.     For Each aa In d1.keys
    
35.       crr = d1(aa)
    
36.       ReDim drr(1 To UBound(crr, 2), 1 To UBound(crr))
    
37.       For i = 1 To UBound(crr)
    
38.         For j = 1 To UBound(crr, 2)
    
39.           drr(j, i) = crr(i, j)
    
40.         Next
    
41.       Next
    
42.       d1(aa) = drr
    
43.     Next
    
44.     For i = 1 To Application.Min(UBound(arr), yxrs)
    
45.       If d.exists(arr(i, 2)) Then
    
46.         m = d(arr(i, 2))
    
47.         brr(m, 3) = brr(m, 3) + 1
    
48.       End If
    
49.     Next
    
50.     For i = 1 To UBound(brr)
    
51.       If d1.exists(brr(i, 1)) Then
    
52.         crr = d1(brr(i, 1))
    
53.         For k = 1 To Application.Min(UBound(crr), brr(i, 2))
    
54.           If crr(k, 3) + 40 >= yxfs Then
    
55.             brr(i, 4) = brr(i, 4) + 1
    
56.           End If
    
57.         Next
    
58.       End If
    
59.     Next
    
60.     yxfs = arr(Application.Min(UBound(arr), yxrs), 3)
    
61.     .Range("g2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
62.   End With
    
63. End Sub
    

复制代码

chxw68

只写了一部分，不知道对不对。

ckh2004

上一线人数是正确的，但定向和定向外不对，我用手动算了下，结果在sheet5中

chxw68

ckh2004 发表于 2018-3-5 18:24
上一线人数是正确的，但定向和定向外不对，我用手动算了下，结果在sheet5中

看不懂数据之间的计算关系，代码只供参考。

wmqz.130

1. Public Sub 一线统计()
   
2. Range("i2:i19").ClearContents
   
3. Dim arr
   
4. arr = Range("a2:c" & [f2] + 1)
   
5. For i = 1 To UBound(arr)
   
6. Set Rng = Range("g2:g19").Find(arr(i, 2), LookIn:=xlValues).Offset(0, 2)
   
7. If Not Rng Is Nothing Then Rng.Value = Rng.Value + 1
   
8. Next
   
9. End Sub

复制代码

1. Public Sub 定向统计()
   
2. Range("j2:k19").ClearContents
   
3. Dim arr
   
4. lw = Range("c" & [f2]).Value
   
5. arr = Range("a" & [f2] + 2 & ":c" & [f1] + 1)
   
6. For i = 1 To UBound(arr)
   
7. Set Rng = Range("g2:g19").Find(arr(i, 2), LookIn:=xlValues).Offset(0, 3)
   
8. If Not Rng Is Nothing Then
   
9. If arr(i, 3) + 40 >= lw And Rng.Value < Rng.Offset(0, -2) Then
   
10. Rng.Value = Rng.Value + 1
    
11. Else
    
12. Rng.Offset(0, 1) = Rng.Offset(0, 1) + 1
    
13. End If
    
14. End If
    
15. Next
    
16. End Sub

复制代码

wmqz.130

ckh2004 发表于 2018-3-5 18:24
上一线人数是正确的，但定向和定向外不对，我用手动算了下，结果在sheet5中

ps 你手工计算的定向和定向外是错误的，我6楼代码得到的结果才是正确的。

ckh2004

谢谢两位老师，辛苦了！

ckh2004

老师：我改动了下数据，还有些问题，请再帮我修改下，谢谢！

zopey

wmqz.130 发表于 2018-3-5 23:49
ps 你手工计算的定向和定向外是错误的，我6楼代码得到的结果才是正确的。

定向统计sub中的 arr = Range("a" & [f2] + 2 & ":c" & [f1] + 1) 这个范围指定的不恰当，
应该不是固定的从第376到750名，而要按学校别 分别统计前几名（按定向名额）取出定向人数。