关于中考录取的VBA，请老师帮忙。

vvw123 · 发表于 2019-6-14 16:28

Excel 平行志愿录取程序请大侠帮助修改谢谢！！-ExcelVBA程序开发-ExcelHome技术论坛 - http://club.excelhome.net/thread-1281838-1-1.html

不知道为什么 · 发表于 2019-6-14 19:42

microyip 发表于 2019-6-14 10:21
我也来凑凑热闹，附上附件以供参考

这道题还是有点意思啊。难怪 microyip老师也出手了。

好像您和鄂龙蒙老师的运行结果都是有点问题哎。

鄂龙蒙老师的结果，标色的应该是符合录取条件的。

不知道为什么 · 发表于 2019-6-14 19:48

microyip 发表于 2019-6-14 10:21
我也来凑凑热闹，附上附件以供参考

如图，我和microyip老师做出的结果也很多不一致。
哎，就留给楼主去核对了。

不知道为什么 · 发表于 2019-6-14 19:56

如图

不知道为什么 · 发表于 2019-6-14 20:07

如图：
假如录取到最后一个计划数，但此时投档分五科总分四科总分都相同的场景下，全部会录取。否则按高到低录取满计划数结束。

不知道为什么 · 发表于 2019-6-14 20:11

microyip · 发表于 2019-6-14 22:46

不知道为什么发表于 2019-6-14 19:42
这道题还是有点意思啊。难怪 microyip老师也出手了。

好像您和鄂龙蒙老师的运行结果 ...

怎么就不符合呢?
            志愿1 等级分定向生投档分
录取条件 8301 <=9          是      >=460
雷建卿    8301 5       是          524.2

不知道为什么 · 发表于 2019-6-14 23:23

microyip 发表于 2019-6-14 22:46
怎么就不符合呢?
志愿1 等级分定向生投档分
录取条件 8301 =460

这个是上面那个老师的结果，我觉得不准确的。呵呵

鄂龙蒙 · 发表于 2019-6-15 10:00

本帖最后由鄂龙蒙于 2019-6-15 10:18 编辑

不知道为什么发表于 2019-6-14 19:42
这道题还是有点意思啊。难怪 microyip老师也出手了。

好像您和鄂龙蒙老师的运行结果 ...

Sub 录取()
Range("A2:A10000") = ""
Dim arr, ar(), br, brr(), cr(), sa, sb
Dim m, n, i, j, x, y, p, a, b, c, r, s, k, t, temp
Dim d As Object
Set d = CreateObject("scripting.dictionary")
sa = Array(2, 3, 4, 9, 18, 19)
sb = Array(1, 2, 4, 5, 6)
arr = Range("A1").CurrentRegion
For i = 2 To UBound(arr)
If VBA.IsNumeric(arr(i, 10)) Then
If arr(i, 11) = "8301" And Val(arr(i, 10)) <= 9 And arr(i, 6) = "是" And arr(i, 9) >= 460 Then
m = m + 1
ReDim Preserve brr(1 To 6, 1 To m)
For j = 0 To 5
brr(j + 1, m) = arr(i, sa(j))
Next
End If
End If
Next
For i = 1 To UBound(brr, 2)
If Not d.exists(brr(3, i)) Then
m = 1
ReDim br(1 To 5, 1 To m)
Else
br = d(brr(3, i))
m = UBound(br, 2) + 1
ReDim Preserve br(1 To 5, 1 To m)
End If
For j = 0 To 4
br(j + 1, m) = brr(sb(j), i)
Next
d(brr(3, i)) = br
Next
k = d.keys
t = d.items
m = 0
arr = Sheet2.Range("L1").CurrentRegion
For x = 0 To d.Count - 1
For i = 1 To UBound(t(x), 2) - 1
p = i
For j = i + 1 To UBound(t(x), 2)
If Val(t(x)(3, p)) < Val(t(x)(3, j)) Then p = j
Next
If p <> i Then
For j = 1 To 5
temp = t(x)(j, i)
t(x)(j, i) = t(x)(j, p)
t(x)(j, p) = temp
Next
End If
Next
Next
For x = 0 To d.Count - 1
For i = 2 To UBound(arr)
If CStr(arr(i, 1)) = k(x) Then
If Val(arr(i, 2)) <= UBound(t(x), 2) Then
If t(x)(4, Val(arr(i, 2))) = t(x)(4, Val(arr(i, 2)) + 1) Then
n = 0: a = 0: b = 0: c = 0: r = 0
For j = Val(arr(i, 2)) To 1 Step -1
If t(x)(4, j) = t(x)(4, j - 1) Then n = n + 1 Else: a = j: Exit For
Next
For j = Val(arr(i, 2)) To UBound(t(x), 2)
If t(x)(4, j) = t(x)(4, j + 1) Then n = n + 1 Else: b = j: Exit For
Next
If n > 0 Then
ReDim cr(1 To n + 1, 1 To 5)
r = 0
For j = a To b
r = r + 1
For y = 1 To 5
cr(r, y) = t(x)(y, j)
Next
Next
For y = 1 To UBound(cr) - 1
p = y
For j = y + 1 To UBound(cr)
If cr(p, 5) < cr(j, 5) Then p = j
Next
If p <> y Then
For j = 1 To 5
temp = cr(y, j)
cr(y, j) = cr(p, j)
cr(p, j) = temp
Next
End If
Next
For j = 1 To a - 1
m = m + 1
ReDim Preserve ar(1 To 5, 1 To m)
For y = 1 To 5
ar(y, m) = t(x)(y, j)
Next
Next
c = Val(arr(i, 2)) - a + 1
For j = 1 To c
m = m + 1
ReDim Preserve ar(1 To 5, 1 To m)
For y = 1 To 5
ar(y, m) = cr(j, y)
Next
Next
End If
Else
For j = 1 To Val(arr(i, 2))
m = m + 1
ReDim Preserve ar(1 To 5, 1 To m)
For y = 1 To 5
ar(y, m) = t(x)(y, j)
Next
Next
End If
Else
For j = 1 To UBound(t(x), 2)
m = m + 1
ReDim Preserve ar(1 To 5, 1 To m)
For y = 1 To 5
ar(y, m) = t(x)(y, j)
Next
Next
End If
End If
Next
Next
arr = Range("A1").CurrentRegion
s = 0
For i = 2 To UBound(arr)
For x = 1 To UBound(ar, 2)
If CStr(arr(i, 2)) = CStr(ar(1, x)) Then Cells(i, 1) = "OK": s = s + 1
Next
Next
MsgBox "共有 " & s & " 名同学录取完毕！"
Set d = Nothing
End Sub
谢谢您认真核对，是有点差错，已修改。

复制代码

鄂龙蒙 · 发表于 2019-6-15 10:04

本帖最后由鄂龙蒙于 2019-6-15 10:24 编辑

附件

录取VBA求教-2019-6-15已修改.rar (627.7 KB, 下载次数: 25)

		自动登录	找回密码
密码			免费注册

[求助] 关于中考录取的VBA，请老师帮忙。

评分

评分

评分