ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

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

[复制链接]

TA的精华主题

TA的得分主题

 楼主| 发表于 2024-4-21 17:43 | 显示全部楼层
笨鸟飞不高 发表于 2024-4-21 13:05
当前附件凑一个!!

做的挺灵活的,就是科目增多,就生不成结果了

TA的精华主题

TA的得分主题

 楼主| 发表于 2024-4-21 22:33 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2024-4-24 14:37 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助

那应该是一开始就没理解楼主的要求!玩不了了!你参照部林老师的吧!!

TA的精华主题

TA的得分主题

发表于 2024-4-28 20:19 | 显示全部楼层
VBA代码:

Option Explicit
Dim myTotal(1 To 4) As Long
    'myTotal(1):女监考员数
    'myTotal(2):监考员总数
    'myTotal(3):考试科目数
    'myTotal(4):设置考场数
Dim i&, j&, k&, m&, strAddr$
Dim Limit& '监考场数上限
Dim mySht(1 To 2) As Worksheet
Dim flagInfo() As String '监考员信息:姓名、本科目选中标记、累计监考场数
Dim nameList() As String '监考安排信息:主考官(女)、副考官
Sub main()
    '监考安排
    Application.ScreenUpdating = False
    Set mySht(1) = ActiveWorkbook.Worksheets("监考名单")
    Set mySht(2) = ActiveWorkbook.Worksheets("监考安排")
    With mySht(1)
        myTotal(2) = .Cells(.Rows.Count, 1).End(xlUp).Row - 1 '监考员总数
        ReDim flagInfo(1 To myTotal(2), 1 To 3) As String
        '数据整理:按性别降序排列
        strAddr = "B1:C" & (myTotal(2) + 1) '排序区域
        .Range(strAddr).Sort Key1:=.Range("C2"), Order1:=xlDescending, Header:=xlYes, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
            :=xlPinYin, DataOption1:=xlSortNormal
        '数组赋初值
        myTotal(1) = 0
        For i = 1 To myTotal(2)
            If .Cells(i + 1, 3).Value = "女" Then
                myTotal(1) = myTotal(1) + 1 '统计女监考员人数
                flagInfo(i, 1) = .Cells(i + 1, 2).Value
                flagInfo(i, 2) = ""
                flagInfo(i, 3) = 0
            Else
                Exit For
            End If
        Next
        For j = i To myTotal(2)
            flagInfo(j, 1) = .Cells(j + 1, 2).Value
            flagInfo(j, 2) = ""
            flagInfo(j, 3) = 0
        Next
    End With
    With mySht(2)
        myTotal(4) = .Cells(.Rows.Count, 1).End(xlUp).Row - 2 '设置考场数
        myTotal(3) = (.Cells(2, .Columns.Count).End(xlToLeft).Column - 1) / 2 '考试科目数
    End With
    If myTotal(1) < myTotal(4) Then
        MsgBox "女监考员不够!"
    Else
        If myTotal(2) < myTotal(4) * 2 Then
            MsgBox "监考员总人数不够!"
        Else
            ReDim nameList(1 To myTotal(4), 1 To myTotal(3) * 2) As String
            Limit = -Int(-myTotal(4) * myTotal(3) * 2 / myTotal(2))
            For i = 1 To myTotal(3)
                监考安排名单 i
            Next
            '更新工作表
            With mySht(2)
                strAddr = "B3:" & .Cells(myTotal(4) + 2, 2 * myTotal(3) + 1).Address
                .Range(strAddr).ClearContents
                .Range(strAddr) = nameList
            End With
        End If
    End If
    Set mySht(1) = Nothing
    Set mySht(2) = Nothing
    Application.ScreenUpdating = True
End Sub
Sub 监考安排名单(ByVal myNo As Long)
    '=======================================================
    '要求解读:
   
    '   1、“随机”不随俗;
   
    '   2、要想好,先有“女”--每组必有一名“女”考官;
   
    '   3、相逢不可曾相识;
   
    '   4、故地不重游;
   
    '   5、莫让伊人独憔悴--监考场次尽量匀衡。
    '=======================================================
    Dim ii&, jj&, mmm&, rndMin&, rndMax&, rndNum&, isTest As Boolean
    Randomize
    For k = 1 To 2 '主、副两名考官
        
'        '主考官为女
'        If k = 1 Then
'            rndMin = 0
'            rndMax = myTotal(1)
'        Else
'            rndMin = myTotal(1)
'            rndMax = myTotal(2) - myTotal(4)
'        End If
        
        '男女搭配
        If k = 1 Then
            rndMin = 0
            rndMax = myTotal(1)
        Else
            rndMin = myTotal(1)
            rndMax = myTotal(2) - myTotal(1)
        End If
        
        For j = 1 To myTotal(4)
            m = 0
            Do
                m = m + 1
                '产生随机数
                Do
                    rndNum = rndMin + Int(Rnd * rndMax) + 1
                    If rndNum > myTotal(2) Then
                        rndNum = rndNum - myTotal(2)
                        mmm = 0
                        For ii = 1 To myTotal(1)
                            If flagInfo(ii, 2) = "" Then
                                mmm = mmm + 1
                                If mmm = rndNum Then
                                    rndNum = ii
                                    Exit For
                                End If
                            End If
                        Next
                    End If
                Loop Until flagInfo(rndNum, 2) = ""
                '条件检测
                isTest = True
                If myNo > 1 Then
                    For ii = 1 To myNo - 1
                        If flagInfo(rndNum, 1) = nameList(j, 2 * ii - 1) Or flagInfo(rndNum, 1) = nameList(j, 2 * ii) Then
                            isTest = False '“故地不重游”检测未通过
                            Exit For
                        End If
                    Next
                    If isTest = True And k > 1 Then
                        For ii = 1 To myNo - 1
                            For jj = 1 To myTotal(4)
                                If nameList(j, 2 * myNo - 1) & flagInfo(rndNum, 1) = nameList(jj, 2 * ii - 1) & nameList(jj, 2 * ii) Or _
                                    nameList(j, 2 * myNo - 1) & flagInfo(rndNum, 1) = nameList(jj, 2 * ii) & nameList(jj, 2 * ii - 1) Then
                                    isTest = False '“相逢不可曾相识”检测未通过
                                    Exit For
                                End If
                            Next
                            If isTest = False Then
                                Exit For
                            End If
                        Next
                    End If
                End If
            Loop While ((isTest = False) Or (flagInfo(rndNum, 3) + 0 = Limit)) And (m < 100)
            '赋值
            If m < 100 Then
                flagInfo(rndNum, 2) = "√"
                flagInfo(rndNum, 3) = flagInfo(rndNum, 3) + 1
                nameList(j, 2 * (myNo - 1) + k) = flagInfo(rndNum, 1)
            End If
        Next
    Next
    '清除标记
    For ii = 1 To myTotal(2)
        flagInfo(ii, 2) = ""
    Next
End Sub



TA的精华主题

TA的得分主题

发表于 2024-4-28 20:26 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
这是男女搭配的:

图片.jpg

这是至少有一女主考官的:

图片.jpg

工作簿.rar (25.3 KB, 下载次数: 13)

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2024-4-28 21:46 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
djk1020 发表于 2024-4-28 20:26
这是男女搭配的:

速度很快,我把男女各30人,考场设为30个,科目增加到9,一直没有成功

TA的精华主题

TA的得分主题

发表于 2024-4-29 11:47 来自手机 | 显示全部楼层
amzxfgh9632 发表于 2024-4-28 21:46
速度很快,我把男女各30人,考场设为30个,科目增加到9,一直没有成功

限制条件m<100是为防止无解时进入死循环或有解但运行时间过长而设置的,对于男女各30人、男女搭配、30个考场9个科目的监考安排是有解的,我某次运行时得到了结果,为使运行结果可预期地稳定得到,准备修改一下算法试试。

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2024-4-29 16:15 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
有点意思,标记一下

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2024-4-30 13:38 | 显示全部楼层
我也试一下,请楼主测试一下怎么样。
科目多了需要增加重算次数。
image.png image.jpg

监考安排.zip

29.27 KB, 下载次数: 14

评分

2

查看全部评分

TA的精华主题

TA的得分主题

发表于 2024-4-30 15:57 | 显示全部楼层
longwin 发表于 2024-4-30 13:38
我也试一下,请楼主测试一下怎么样。
科目多了需要增加重算次数。

这个有用,支持一下
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-12-25 16:10 , Processed in 0.051754 second(s), 10 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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