能力有限，真搞不定，求救！

jx928867128

zpy2 发表于 2024-6-23 11:39
我觉得你真的小看了汇划求解，特别是上一点规模的

非常感谢您多次的关注与回贴，再次感谢您，听很多热心的坛友说过排课和监考问题是规划求解问题，但我完全不懂建模啊

jx928867128

Sub 按钮8_Click()    '子程序 按钮8_<点击>()
Sum = 0    'Sum=0
Sheets(2).[a1].CurrentRegion.Offset(1, 1).ClearContents    '<工作表>(2 )的[a1]的 当前区域的<偏移>(1,1 )的清除内容
lxl:    'lxl:
Sum = Sum + 1    'Sum=Sum+1
If Sum = 999 Then    '如果 Sum=999 则执行
    MsgBox "GAME OVER"    '<消息框>："GAMEOVER"
    Exit Sub    '退出子程序
End If    'If判断过程结束
Set d = CreateObject("scripting.dictionary")    '设定d=<创建工程>("scripting.dictionary")
Set dw = CreateObject("scripting.dictionary")    '设定dw=<创建工程>("scripting.dictionary")
Set dd = CreateObject("scripting.dictionary")    '设定dd=<创建工程>("scripting.dictionary")
arr = Sheets(1).[a1].CurrentRegion    'arr=<工作表>(1 )的[a1]的当前区域
For j = 2 To UBound(arr)    '设定变量范围为j=2到<数组上限>(arr)
    Set dd(arr(j, 1)) = CreateObject("scripting.dictionary")    '设定dd(arr(j,1))=<创建工程>("scripting.dictionary")
    For i = 2 To UBound(arr, 2)    '设定变量范围为i=2到<数组上限>(arr,2)
        If Not d.exists(arr(j, i)) And Len(arr(j, i)) > 0 Then    '如果  非  d的存在arr(j,i)) 并且 <字符串长度值>(arr(j,i))>0 则执行
            Set d(arr(j, i)) = CreateObject("scripting.dictionary")    '设定d(arr(j,i))=<创建工程>("scripting.dictionary")
        End If    'If判断过程结束
        d(arr(j, i))(arr(j, 1)) = -1    'd(arr(j,i))(arr(j,1))=-1
        dd(arr(j, 1))(arr(j, i)) = 0    'dd(arr(j,1))(arr(j,i))=0
    Next i    '下一个i
Next j    '下一个j
arr = Sheets(2).[a1].CurrentRegion    'arr=<工作表>(2 )的[a1]的当前区域
For i = 2 To UBound(arr, 2)    '设定变量范围为i=2到<数组上限>(arr,2)
    For j = 2 To UBound(arr)    '设定变量范围为j=2到<数组上限>(arr)
        For w = -1 To UBound(arr, 2)    '设定变量范围为w=-1到<数组上限>(arr,2)
            dw.RemoveAll    ' dw的RemoveAll
            For x = 1 To d.Count    '设定变量范围为x=1到 d的计数值
                dw(x) = ""    'dw(x)=空值
            Next x    '下一个x
            For xx = 1 To d.Count    '设定变量范围为xx=1到 d的计数值
                y = WorksheetFunction.RandBetween(0, dw.Count - 1)    'y= 工作表公式的RandBetween(0, dw的计数值-1)
                x = dw.keys()(y)    'x= dw的keys()(y)
                dw.Remove x    ' dw的移除 x
                k = d.keys()(x - 1)    'k= d的keys()(x-1)
                If d(k).exists(arr(j, 1)) Then    '如果 d(k )的存在arr(j,1)) 则执行
                    If d(k)(arr(j, 1)) = w Then    '如果 d(k)(arr(j,1))=w 则执行
                        zz = 0    'zz=0
                        For Each kk In d(k).items    '设定变量范围为每一个kk位于d(k )的items
                            If kk = i Then zz = 1    '如果 kk=i 则执行 zz=1
                        Next    '下一个
                        If zz = 0 Then    '如果 zz=0 则执行
                            arr(j, i) = k    'arr(j,i)=k
                            d(k)(arr(j, 1)) = i    'd(k)(arr(j,1))=i
                            GoTo 11    ' 跳至 11
                        End If    'If判断过程结束
                    End If    'If判断过程结束
                End If    'If判断过程结束
            Next xx    '下一个xx
        Next w    '下一个w
11:            '11:
    Next j    '下一个j
Next i    '下一个i
For j = 2 To UBound(arr)    '设定变量范围为j=2到<数组上限>(arr)
    For i = 2 To UBound(arr, 2)    '设定变量范围为i=2到<数组上限>(arr,2)
        If Len(arr(j, i)) = 0 Then    '如果 <字符串长度值>(arr(j,i))=0 则执行
            For n = 0 To dd(arr(j, 1)).Count - 1    '设定变量范围为n=0到dd(arr(j,1) )的计数值-1
                k = dd(arr(j, 1)).keys()(n)    'k=dd(arr(j,1) )的keys()(n)
                If k <> arr(j, i - 1) Then    '如果 k 不等于 arr(j,i-1) 则执行
                    If i < UBound(arr, 2) Then    '如果 i<<数组上限>(arr,2) 则执行
                        If k <> arr(j, i + 1) Then    '如果 k 不等于 arr(j,i+1) 则执行
                            For w = 2 To UBound(arr)    '设定变量范围为w=2到<数组上限>(arr)
                                If w <> j Then    '如果 w 不等于 j 则执行
                                    If k = arr(w, i) Then    '如果 k=arr(w,i) 则执行
                                        For Z = 2 To UBound(arr, 2)    '设定变量范围为Z=2到<数组上限>(arr,2)
                                            For y = 2 To UBound(arr)    '设定变量范围为y=2到<数组上限>(arr)
                                                If arr(y, Z) = k Then GoTo 12    '如果 arr(y,Z)=k 则执行  跳至 12
                                                If arr(w, Z) = arr(y, i) Then GoTo 12    '如果 arr(w,Z)=arr(y,i) 则执行  跳至 12
                                            Next y    '下一个y
                                            arr(j, i) = k    'arr(j,i)=k
                                            tm = arr(w, Z)    'tm=arr(w,Z)
                                            arr(w, Z) = k    'arr(w,Z)=k
                                            arr(w, i) = tm    'arr(w,i)=tm
                                            GoTo 13    ' 跳至 13
12:                                                '12:
                                        Next Z    '下一个Z
                                    End If    'If判断过程结束
                                End If    'If判断过程结束
                            Next w    '下一个w
                        End If    'If判断过程结束
                    End If    'If判断过程结束
                End If    'If判断过程结束
            Next n    '下一个n
13:                '13:
        End If    'If判断过程结束
    Next i    '下一个i
Next j    '下一个j
For j = 2 To UBound(arr)    '设定变量范围为j=2到<数组上限>(arr)
    For i = 2 To UBound(arr, 2)    '设定变量范围为i=2到<数组上限>(arr,2)
        If Len(arr(j, i)) = 0 Then    '如果 <字符串长度值>(arr(j,i))=0 则执行
            GoTo lxl:    ' 跳至 lxl:
        End If    'If判断过程结束
    Next i    '下一个i
Next j    '下一个j
For j = 2 To UBound(arr)    '设定变量范围为j=2到<数组上限>(arr)
    For i = 4 To UBound(arr, 2) - 1    '设定变量范围为i=4到<数组上限>(arr,2)-1
        If arr(j, i - 1) = arr(j, i - 2) Then    '如果 arr(j,i-1)=arr(j,i-2) 则执行
            If arr(j, i) = arr(j, i - 1) Or arr(j, i + 1) = arr(j, i - 1) Then    '如果 arr(j,i)=arr(j,i-1)或者arr(j,i+1)=arr(j,i-1) 则执行
                GoTo lxl:    ' 跳至 lxl:
            End If    'If判断过程结束
        End If    'If判断过程结束
    Next i    '下一个i
Next j    '下一个j
For j = 2 To UBound(arr)    '设定变量范围为j=2到<数组上限>(arr)
    For i = 2 To UBound(arr, 2) - 3    '设定变量范围为i=2到<数组上限>(arr,2)-3
        If arr(j, i + 2) = arr(j, i + 3) Then    '如果 arr(j,i+2)=arr(j,i+3) 则执行
            If arr(j, i) = arr(j, i + 2) Or arr(j, i + 1) = arr(j, i + 2) Then    '如果 arr(j,i)=arr(j,i+2)或者arr(j,i+1)=arr(j,i+2) 则执行
                GoTo lxl:    ' 跳至 lxl:
            End If    'If判断过程结束
        End If    'If判断过程结束
    Next i    '下一个i
Next j    '下一个j
Sheets(2).[a1].CurrentRegion = arr    '<工作表>(2 )的[a1]的当前区域=arr
MsgBox "数据提取完毕！"    '<消息框>："数据提取完毕！"
End Sub    '子程序结束

yjh_27

这组数据可秒杀。上传2个结果。

jx928867128

yjh_27 发表于 2024-7-7 13:42
这组数据可秒杀。上传2个结果。

感谢老师的关注与回贴，期待你这个版本监考程序在本论坛分坛出来！