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

geocm · 发表于 2019-6-13 18:52

关于中考录取的VBA，请老师帮忙。内容在文件中。谢谢

鄂龙蒙 · 发表于 2019-6-13 21:47

录取VBA求教.rar (624.02 KB, 下载次数: 19)

鄂龙蒙 · 发表于 2019-6-13 21:50

《如五科总分仍相同》没考虑，楼主自己处理吧

geocm · 发表于 2019-6-13 22:00

鄂龙蒙发表于 2019-6-13 21:50
《如五科总分仍相同》没考虑，楼主自己处理吧

感谢连夜帮我写出代码。

鄂龙蒙 · 发表于 2019-6-14 07:55

Sub 录取()
Range("A2:A10000") = ""
Dim arr, ar(), br, brr(), cr()
Dim m, n, i, j, x, y, p, a, b, c, s, k, t, temp
Dim d As Object
Set d = CreateObject("scripting.dictionary")
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)
brr(1, m) = arr(i, 2)
brr(2, m) = arr(i, 3)
brr(3, m) = arr(i, 4)
brr(4, m) = arr(i, 9)
brr(5, m) = arr(i, 18)
brr(6, m) = arr(i, 19)
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
br(1, m) = brr(1, i)
br(2, m) = brr(2, i)
br(3, m) = brr(4, i)
br(4, m) = brr(5, i)
br(5, m) = brr(6, i)
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 t(x)(4, p) < t(x)(4, 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
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: 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 To 5)
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

复制代码

vvw123 · 发表于 2019-6-14 08:26

应该按照计划数来录取的吧

vvw123 · 发表于 2019-6-14 08:30

另外录取结果显示学校比较直观

microyip · 发表于 2019-6-14 10:19

鄂龙蒙发表于 2019-6-14 07:55

现在很厉害哦，点赞一个啊，给你加分

microyip · 发表于 2019-6-14 10:20

我也来凑凑热闹

Sub 录取ByMicro()
Dim dicCondition As Object, vKey As Variant, dicCol As Object, vCol As Variant, bRight As Boolean
Dim vData As Variant, nRow As Integer, nScoreCol As Integer
Dim dicStudent As Object, sSchool As String, vScore As Variant, sID As String
Dim vInfo As Variant, vFill As Variant, nStudent As Integer, vTmp As Variant
Set dicCol = CreateObject("Scripting.Dictionary")
Set dicCondition = CreateObject("Scripting.Dictionary")
Set dicStudent = CreateObject("Scripting.Dictionary")
With Sheet2
vData = .[A2:H3].Value '录取条件
For vCol = 1 To UBound(vData, 2)
vKey = Trim(vData(1, vCol))
vTmp = Trim(vData(2, vCol))
If vKey = "定向生" Then vTmp = """" & vTmp & """"
If vTmp Like "*=*" Or vTmp Like "*>*" Or vTmp Like "*<*" Then
dicCondition(vKey) = vTmp
Else
dicCondition(vKey) = "=" & vTmp
End If
Next
With Sheet1
.UsedRange.Offset(1).Resize(, 1).ClearContents
vInfo = .UsedRange.Value '考生资料
For vCol = 1 To 19
vKey = Trim(vInfo(1, vCol))
If dicCondition.Exists(vKey) Then dicCol(vCol) = vKey
If vKey = "投档分" Then nScoreCol = vCol '注意：条件内必须包含投档分作为后面比较用途
Next
For nRow = 2 To UBound(vInfo)
bRight = True
For Each vCol In dicCol.Keys
vKey = dicCol(vCol)
If vKey = "定向生" Then
vTmp = """" & vInfo(nRow, vCol) & """" & dicCondition(vKey)
Else
vTmp = vInfo(nRow, vCol) & dicCondition(vKey)
End If
bRight = bRight And Application.Evaluate(vTmp)
If Not bRight Then Exit For
Next
If bRight Then
vInfo(nRow, 1) = "OK"
sID = Trim(vInfo(nRow, 2)) '考生号
sSchool = Trim(vInfo(nRow, 4)) '学校
vScore = Val(vInfo(nRow, nScoreCol)) '投档分
If Not dicStudent.Exists(sSchool) Then Set dicStudent(sSchool) = CreateObject("Scripting.Dictionary")
dicStudent(sSchool)("总人数") = dicStudent(sSchool)("总人数") + 1
If Not dicStudent(sSchool).Exists(vScore) Then Set dicStudent(sSchool)(vScore) = CreateObject("Scripting.Dictionary")
dicStudent(sSchool)(vScore)(sID) = nRow
End If
Next
End With
With .[L2].CurrentRegion.Resize(, 2)
vData = .Offset(1).Resize(.Rows.Count - 1).Value '学校招生计划资料
ReDim vFill(1 To UBound(vData), 1 To 2)
End With
For nRow = 1 To UBound(vData)
sSchool = Trim(vData(nRow, 1))
nStudent = Val(vData(nRow, 2)) '计划数
If dicStudent.Exists(sSchool) Then
If dicStudent(sSchool)("总人数") > nStudent Then
vCol = DataSort(dicStudent(sSchool).Keys())
For Each vScore In vCol
If vScore <> "总人数" Then
Set vTmp = dicStudent(sSchool)(vScore)
dicStudent(sSchool).Remove vScore
Set dicStudent(sSchool)(vScore) = vTmp
End If
Next
For Each vScore In dicStudent(sSchool).Keys
If vScore <> "总人数" Then
If dicStudent(sSchool)("总人数") - dicStudent(sSchool)(vScore).Count > nStudent Then
dicStudent(sSchool)("总人数") = dicStudent(sSchool)("总人数") - dicStudent(sSchool)(vScore).Count
dicStudent(sSchool).Remove vScore
Else
Do While dicStudent(sSchool)("总人数") > nStudent
Randomize
vCol = Int(Rnd() * dicStudent(sSchool)(vScore).Count)
dicStudent(sSchool)(vScore).Remove dicStudent(sSchool)(vScore).Keys()(vCol)
dicStudent(sSchool)("总人数") = dicStudent(sSchool)("总人数") - 1
Loop
End If
End If
Next
End If
vFill(nRow, 1) = dicStudent(sSchool).Keys()(1)
vFill(nRow, 2) = dicStudent(sSchool)("总人数")
End If
Next
.[N2:O2].Resize(UBound(vFill)) = vFill
End With
Sheet1.[A1].Resize(UBound(vInfo)) = vInfo
End Sub
Function DataSort(ByVal vData As Variant) As Variant
Dim nI As Double, nJ As Double, vTmp As Variant
nJ = LBound(vData)
For nI = LBound(vData) To UBound(vData) - 1
If Val(vData(nI)) <= Val(vData(nI + 1)) Then
If nI > nJ Then
nJ = nI
Else
nI = nJ
End If
Else
vTmp = vData(nI)
vData(nI) = vData(nI + 1)
vData(nI + 1) = vTmp
If nI <> LBound(vData) Then nI = nI - 2
End If
Next nI
DataSort = vData
End Function

复制代码

microyip · 发表于 2019-6-14 10:21

我也来凑凑热闹，附上附件以供参考

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

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

评分

评分

最新热点 /1