ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: amzxfgh9632

[求助] 一个奇葩的监考安排

[复制链接]

TA的精华主题

TA的得分主题

发表于 2024-5-3 09:25 | 显示全部楼层
amzxfgh9632 发表于 2024-4-30 20:51
这样随机安排女+男,男+女,女+女更加合理了,但把考场设成30,基本没有正确的结果

改变了一下算法,重新写了,请测试。[url=]附件[/url]

监考安排.zip

31.11 KB, 下载次数: 13

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2024-5-3 17:22 | 显示全部楼层
longwin 发表于 2024-5-3 09:25
改变了一下算法,重新写了,请测试。附件

66666,相当厉害

TA的精华主题

TA的得分主题

发表于 2024-5-4 10:47 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
longwin 发表于 2024-5-3 09:25
改变了一下算法,重新写了,请测试。附件

同一考場不可進入兩次或以上//

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2024-5-4 11:59 | 显示全部楼层
准提部林 发表于 2024-5-4 10:47
同一考場不可進入兩次或以上//

是的,同一个人监考同一考场多次了

TA的精华主题

TA的得分主题

 楼主| 发表于 2024-5-4 13:19 | 显示全部楼层
longwin 发表于 2024-5-3 09:25
改变了一下算法,重新写了,请测试。附件

老师您 好,每个监考官只能和每个学生见一次面哦

TA的精华主题

TA的得分主题

发表于 2024-5-4 23:21 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
确实有问题,已修改,请测试。

[url=]附件[/url]

监考安排.zip

33.13 KB, 下载次数: 17

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2024-5-5 11:22 | 显示全部楼层
参考了一下本贴高手的算法,原算法是先选再检测,修改后的算法是先剔除再选,这样效率高多了。

奇葩监考安排.rar (27.43 KB, 下载次数: 15)
源码如下:
Option Explicit
Dim i&, j&, k&, m&, n&, strAddr$, Sex$, isSuccess As Boolean
Dim myTotal(1 To 4) As Long
                            'myTotal(1):主监考员数
                            'myTotal(2):监考员总数
                            'myTotal(3):考试科目数
                            'myTotal(4):设置考场数
Dim JKYinfo                 '监考员信息:编号、姓名、性别、累计监考场数
Dim Zkbx$, Fkbx$, Fktemp(1 To 2) As String, myArr
Dim nameList() As String    '监考安排信息:主考官、副考官
Dim bhList() As String      '编号
Dim mySht(1 To 2) As Worksheet
Sub main()
    Dim Max&
    Application.ScreenUpdating = False
    Max = 100                  '重算最大次数
    Set mySht(1) = ActiveWorkbook.Worksheets("监考名单")
    Set mySht(2) = ActiveWorkbook.Worksheets("监考安排")
    With mySht(1)
        myTotal(2) = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
        .Range("D2:D" & (myTotal(2) + 1)).ClearContents
        JKYinfo = .Range("A2:D" & (myTotal(2) + 1))
    End With
    Sex = IIf(MsgBox("主考官是女教师吗?", vbYesNo + vbQuestion) = vbYes, "女", "男")
    Zkbx = ""
    Fktemp(1) = ""
    Fktemp(2) = ""
    For i = 1 To myTotal(2)
        If JKYinfo(i, 3) = Sex Then
            Zkbx = Zkbx & Right("00" & JKYinfo(i, 1), 3) & "|"
        Else
            Fktemp(1) = Fktemp(1) & Right("00" & JKYinfo(i, 1), 3) & "|"
        End If
        Fktemp(2) = Fktemp(2) & Right("00" & JKYinfo(i, 1), 3) & "|"
    Next
    myTotal(1) = UBound(Split(Zkbx, "|"))
    With mySht(2)
        myTotal(3) = (.Cells(2, .Columns.Count).End(xlToLeft).Column - 1) / 2   '考试科目数
        myTotal(4) = .Cells(.Rows.Count, 1).End(xlUp).Row - 2                   '设置考场数
    End With
    If myTotal(1) < myTotal(4) Then
        MsgBox "主监考员不够!"
    Else
        If myTotal(2) < myTotal(4) * 2 Then
            MsgBox "监考员总人数不够!"
        Else
            If myTotal(1) = myTotal(4) Then '只能男女搭配
                Fkbx = Fktemp(1)
            Else
                If myTotal(2) - myTotal(1) >= myTotal(4) Then '提供选择
                    If MsgBox("男女搭配吗?", vbYesNo + vbQuestion) = vbYes Then
                        Fkbx = Fktemp(1)
                    Else
                        Fkbx = Fktemp(2)
                    End If
                Else
                    Fkbx = Fktemp(2)
                End If
            End If
            ReDim bhList(1 To myTotal(4), 1 To myTotal(3) * 2) As String
            n = 0
            Do
                ReDim nameList(1 To myTotal(4), 1 To myTotal(3) * 2) As String
                isSuccess = True
                For i = 1 To myTotal(3)
                    监考安排 i
                    If isSuccess = False Then
                        If n < Max Then
                            For m = 1 To myTotal(2)
                                JKYinfo(m, 4) = 0
                            Next
                        End If
                        Exit For
                    End If
                Next
            Loop While n < Max And isSuccess = False
            '清除内容
            strAddr = "B3:" & mySht(2).Cells(myTotal(4) + 2, 2 * myTotal(3) + 1).Address
            mySht(2).Range(strAddr).ClearContents
            '更新工作表
            If isSuccess = True Then
                mySht(2).Range(strAddr) = nameList
                For i = 1 To myTotal(2)
                    mySht(1).Cells(i + 1, 4).Value = JKYinfo(i, 4)
                Next
            Else
                If MsgBox("已运行了" & n & "次,未找到完全解!写入已安排数据吗?", vbYesNo + vbQuestion) = vbYes Then
                    mySht(2).Range(strAddr) = nameList
                    For i = 1 To myTotal(2)
                        mySht(1).Cells(i + 1, 4).Value = JKYinfo(i, 4)
                    Next
                End If
            End If
        End If
    End If
    Set mySht(1) = Nothing
    Set mySht(2) = Nothing
    Application.ScreenUpdating = True
End Sub
Sub 监考安排(ByVal myNo As Long)
    '先安排一科考试各考场的主考再安排副考官
    Dim ii&, jj&, rndNum&, strBxTemp(1 To 2) As String, strBx$
    strBxTemp(1) = Zkbx
    strBxTemp(2) = Fkbx
    If myNo = 1 Then '第一科监考安排
        For k = 1 To 2
            Randomize
            For j = 1 To myTotal(4)
                myArr = Split(strBxTemp(k), "|")
                rndNum = Int(Rnd * UBound(myArr))
                JKYinfo(CInt(myArr(rndNum)), 4) = JKYinfo(CInt(myArr(rndNum)), 4) + 1
                nameList(j, k) = JKYinfo(CInt(myArr(rndNum)), 2)
                bhList(j, k) = myArr(rndNum)
                strBxTemp(1) = Replace(strBxTemp(1), myArr(rndNum) & "|", "") '从备选库删除本次选出的
                strBxTemp(2) = Replace(strBxTemp(2), myArr(rndNum) & "|", "")
            Next
        Next
    Else
        '选主考
        Randomize
        For j = 1 To myTotal(4)
            strBx = strBxTemp(1)
            For jj = 1 To myNo - 1 '从备选库中剔除本考场前面科目安排过的人
                strBx = Replace(strBx, bhList(j, 2 * jj - 1) & "|", "")
                strBx = Replace(strBx, bhList(j, 2 * jj) & "|", "")
            Next
            If strBx = "" Then
                n = n + 1
                isSuccess = False
                Exit Sub
            Else
                myArr = Split(strBx, "|")
                rndNum = Int(Rnd * UBound(myArr))
                JKYinfo(CInt(myArr(rndNum)), 4) = JKYinfo(CInt(myArr(rndNum)), 4) + 1
                nameList(j, 2 * myNo - 1) = JKYinfo(CInt(myArr(rndNum)), 2)
                bhList(j, 2 * myNo - 1) = myArr(rndNum)
                strBxTemp(1) = Replace(strBxTemp(1), myArr(rndNum) & "|", "") '从备选库删除本次选出的
                strBxTemp(2) = Replace(strBxTemp(2), myArr(rndNum) & "|", "")
            End If
        Next
        '选副考
        Randomize
        For j = 1 To myTotal(4)
            strBx = strBxTemp(2)
            For jj = 1 To myNo - 1
                strBx = Replace(strBx, bhList(j, 2 * jj - 1) & "|", "") '从备选库中剔除本考场前面科目安排过的人
                strBx = Replace(strBx, bhList(j, 2 * jj) & "|", "")
                For ii = 1 To myTotal(4)                                '前面科目安排中与该科该考场主考搭档过的也要从备选库移除
                    If JKYinfo(CInt(bhList(ii, 2 * jj - 1)), 2) = nameList(j, 2 * myNo - 1) Then
                        strBx = Replace(strBx, bhList(ii, 2 * jj) & "|", "")
                    End If
                    If JKYinfo(CInt(bhList(ii, 2 * jj)), 2) = nameList(j, 2 * myNo - 1) Then
                        strBx = Replace(strBx, bhList(ii, 2 * jj - 1) & "|", "")
                    End If
                Next
            Next
            If strBx = "" Then
                n = n + 1
                isSuccess = False
                Exit Sub
            Else
                myArr = Split(strBx, "|")
                rndNum = Int(Rnd * UBound(myArr))
                JKYinfo(CInt(myArr(rndNum)), 4) = JKYinfo(CInt(myArr(rndNum)), 4) + 1
                nameList(j, 2 * myNo) = JKYinfo(CInt(myArr(rndNum)), 2)
                bhList(j, 2 * myNo) = myArr(rndNum)
                strBxTemp(1) = Replace(strBxTemp(1), myArr(rndNum) & "|", "") '从备选库删除本次选出的
                strBxTemp(2) = Replace(strBxTemp(2), myArr(rndNum) & "|", "")
            End If
        Next
    End If
End Sub




评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2024-5-5 11:40 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
一般考试不会超过9科,但考场数可能就比较多,如高考考场一般就在100以上。修改后试了一下:150个考场,300监考员,18科考试,很快得到答案。

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2024-5-5 11:45 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
longwin 发表于 2024-5-4 23:21
确实有问题,已修改,请测试。

附件

將5個或更多的[男]改成[女],,,即男女人數不相同, 再測幾次看看,,,
會有重覆配對情形~~~

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2024-5-5 12:09 | 显示全部楼层
這是配對檢查...放在[监考安排]表執行//
Sub Test_TTT()
Dim Arr, xD, i&, j%, T1$, T2$, X1$, X2$
Set xD = CreateObject("Scripting.Dictionary")
Sheet2.UsedRange.Interior.ColorIndex = 0
Arr = Sheet2.Range("a1").CurrentRegion
For i = 3 To UBound(Arr)
    For j = 2 To UBound(Arr, 2) Step 2
        T1 = Arr(i, j): T2 = Arr(i, j + 1)
        If T1 = "" Or T2 = "" Then GoTo j01
        X1 = T1 & "\" & T2
        X2 = T2 & "\" & T1
        If xD(X1) Then
           Union(Cells(xD(X1) + 2, xD(X1 & "j") + 1).Resize(1, 2), Cells(i + 2, j + 1).Resize(1, 2)).Interior.ColorIndex = 8
        End If
        If xD(X2) Then
           Union(Cells(xD(X2) + 2, xD(X2 & "j") + 1).Resize(1, 2), Cells(i + 2, j + 1).Resize(1, 2)).Interior.ColorIndex = 8
        End If
        xD(X1) = i: xD(X1 & "j") = j
        xD(X2) = i: xD(X2 & "j") = j
j01: Next j
Next i
End Sub

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-12-25 15:41 , Processed in 0.051960 second(s), 19 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表