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

wmqz.130

ckh2004 发表于 2018-3-6 11:05
老师：我改动了下数据，还有些问题，请再帮我修改下，谢谢！

1. Public arr As Variant, lr As Integer, 学校数 As Integer
   
2. Public Sub 一键生成()
   
3. Application.ScreenUpdating = False
   
4. Sheet3.Cells.ClearContents
   
5. lr = Sheet1.Range("a65536").End(xlUp).Row
   
6. Call 排序处理
   
7. Call 学校名称处理
   
8. Sheet3.[a1:f1] = Array("学校", "定向分配人数", "一线", "定向", "定向外", "合计上线")
   
9. For i = 1 To Sheet2.[f2].Value
   
10. Set Rng = Sheet3.Range("a2:a" & 学校数).Find(arr(i, 2)).Offset(0, 2)
    
11. If Not Rng Is Nothing Then Rng.Value = Rng.Value + 1
    
12. Next
    
13. Call 定向统计
    
14. Application.ScreenUpdating = True
    
15. End Sub
    
16. Public Sub 排序处理()
    
17. Application.ScreenUpdating = False
    
18. Sheet1.Select
    
19. yrr = Sheet1.Range("a1:c" & lr)
    
20. Sheet1.Range("a2:c" & lr).Sort Key1:=Cells(2, 3).Resize(lr - 1), Order1:=xlDescending
    
21. arr = Sheet1.Range("a2:c" & lr)
    
22. Sheet1.[a1].Resize(lr, 3) = yrr
    
23. Sheet3.Select
    
24. Application.ScreenUpdating = True
    
25. End Sub
    
26. 
    
27. Public Sub 学校名称处理()
    
28. Application.ScreenUpdating = False
    
29. Dim d As Object
    
30.   Set d = CreateObject("scripting.dictionary")
    
31.   For i = 1 To lr - 1
    
32.   d(arr(i, 2)) = ""
    
33.   Next
    
34.   Sheet3.[a2].Resize(d.Count, 1) = Application.Transpose(d.Keys)
    
35.   For i = 2 To Sheet2.[a1000].End(xlUp).Row
    
36.    For j = 2 To d.Count + 1
    
37.    If Sheet2.Cells(i, 1).Value = Sheet3.Cells(j, 1).Value Then Sheet3.Cells(j, 1).Offset(0, 1) = Sheet2.Cells(i, 1).Offset(0, 1)
    
38.    Next
    
39.   Next
    
40.   学校数 = d.Count
    
41. Application.ScreenUpdating = True
    
42. End Sub
    
43. 
    
44. Public Sub 定向统计()
    
45. lw = arr(Sheet2.[f2].Value, 3)
    
46. For i = Sheet2.[f2].Value + 1 To Sheet2.[f1].Value
    
47. Set Rng = Sheet3.Range("a2:a" & 学校数).Find(arr(i, 2)).Offset(0, 3)
    
48. If Not Rng Is Nothing Then
    
49. If arr(i, 3) + 40 >= lw And Rng.Value < Rng.Offset(0, -2) Then
    
50. Rng.Value = Rng.Value + 1
    
51. Else
    
52. Rng.Offset(0, 1) = Rng.Offset(0, 1) + 1
    
53. End If
    
54. End If
    
55. Next
    
56. Range("F2:F" & 学校数 + 1).FormulaR1C1 = "=SUM(RC[-3]:RC[-1])"
    
57. End Sub

复制代码

wmqz.130

学生上线人数统计.rar (69.15 KB, 下载次数: 8)

2018-3-7 09:08 上传

点击文件名下载附件

zopey

直接操作单元格，因为没用数组，运行速度可能较慢

上线统计.zip (87.56 KB, 下载次数: 12)

2018-3-7 10:22 上传

点击文件名下载附件

Private Sub CommandButton1_Click()
Range("g3").ClearContents
Range("e2:e65535").ClearContents

Set cnn = CreateObject("adodb.connection")
cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
'一线
Sql2 = "select top " & [g2].Value & " * from [sheet1$a:e] order by 总分 desc"
    Set rst2 = CreateObject("adodb.Recordset")
    rst2.Open Sql2, cnn, 1, 1
    Do While Not rst2.EOF
       Cells(rst2("序号") + 1, 5).Value = "一线"
       k = k + 1
    rst2.movenext
    Loop
    rst2.movelast: [g3].Value = rst2("总分")

Application.ScreenUpdating = False
'定向
For i = 2 To [i2].End(xlDown).Row
Sql2 = "select top " & Cells(i, 9).Value & " * from [sheet1$a:e] where 学校='" & Cells(i, 8).Value & "' and 上线否 is null order by 总分 desc"
    Set rst2 = CreateObject("adodb.Recordset")
    rst2.Open Sql2, cnn, 1, 1
    Do While Not rst2.EOF
       If rst2("总分") + 40 >= [g3].Value Then Cells(rst2("序号") + 1, 5).Value = "定向": k = k + 1
    rst2.movenext
    Loop
Next

'定向外
Sql2 = "select top " & [g1].Value - k & " * from [sheet1$a:e] where 上线否 is null order by 总分 desc"
    Set rst2 = CreateObject("adodb.Recordset")
    rst2.Open Sql2, cnn, 1, 1
    Do While Not rst2.EOF
       Cells(rst2("序号") + 1, 5).Value = "定向外"
    rst2.movenext
    Loop

cnn.Close
Set cnn = Nothing

Application.ScreenUpdating = True
End Sub

Private Sub CommandButton2_Click()
Range("j2:m65535").ClearContents

Set cnn = CreateObject("adodb.connection")
cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
For i = 2 To [i2].End(xlDown).Row
Sql2 = "select 上线否,count(*) as 上线人数 from [sheet1$a:e] where 学校='" & Cells(i, 8).Value & "' and 上线否 is not null group by 上线否"
    Set rst2 = CreateObject("adodb.Recordset")
    rst2.Open Sql2, cnn, 1, 1
    Do While Not rst2.EOF
       If rst2("上线否") = "一线" Then
          Cells(i, 10).Value = rst2("上线人数")
       ElseIf rst2("上线否") = "定向" Then
          Cells(i, 11).Value = rst2("上线人数")
       ElseIf rst2("上线否") = "定向外" Then
          Cells(i, 12).Value = rst2("上线人数")
       End If
       Cells(i, 13).Value = Cells(i, 13).Value + rst2("上线人数")
    rst2.movenext
    Loop
Next
cnn.Close
Set cnn = Nothing
End Sub

ckh2004

非常感谢几位教师的无私奉献，zopey老师和wmqz.130老师的文件测试都完全成功，再次感谢各位老师的辛勤劳动！！！！！！

zopey

有没有这种可能，某学生的总分 还可以，因为所报学校名额已满的原因，不能上线。
换个说法就是，
如果总共招生 700人，最后上线的一定是总分排前700的那些人吗？

wmqz.130

zopey 发表于 2018-3-7 14:19
有没有这种可能，某学生的总分 还可以，因为所报学校名额已满的原因，不能上线。
换个说法就是，
如果总 ...

你换了个说法的说法是正确的。

ckh2004

zopey 发表于 2018-3-7 14:19
有没有这种可能，某学生的总分 还可以，因为所报学校名额已满的原因，不能上线。
换个说法就是，
如果总 ...

分数完全相同的话是可以被录取的，在这种情况下实际招生人数可以多出一两个人。

zopey

ckh2004 发表于 2018-3-7 17:46
分数完全相同的话是可以被录取的，在这种情况下实际招生人数可以多出一两个人。

假设一种极端情况，当 “一线”+“定向” 人数超过招生总数，这时“定向外“人数 为0或负值，
就会出现因为学校别的原因，分数高的 不能上线，分数低的反而上线。

LMY123

Do While Not rst2.EOF