求个按计划筛选安排人员的代码

779846526

chxw68 发表于 2019-1-17 12:33
抱歉！水平有限，另请高明吧。

谢谢您的多次帮助，再次谢谢老师，我估计在论坛里本贴基本上是无结果的。

779846526

本贴2位大师级老师都参与了，没能实现结果，期待各位路过的高手练练手啊

chxw68

779846526 发表于 2019-1-17 13:37
本贴2位大师级老师都参与了，没能实现结果，期待各位路过的高手练练手啊

我们用一个极端情况来说明数据是否存在不合理性，比如在总课表里只安排第一节课，只要教室足够，这样也可以把安排表里的所有学生都安排下，但由于安排表里的很多学生都有3门课要上，由于同一个学生同一节课只能上一门课，这样虽然教室安排得足够，还是存在有的学生安排不了节次和教室的情况？你现在只提供了3节的教室安排，我不知道是否也存在这样的情况？我建议你花上点时间用手工看看能不能排出来。

779846526

chxw68 发表于 2019-1-17 14:23
我们用一个极端情况来说明数据是否存在不合理性，比如在总课表里只安排第一节课，只要教室足够，这样也可 ...

好的，我先手工排出个结果出来，再上传下哈

一把小刀闯天下

'好玩而已，，，

'运行到"政治B"，人数不够，人数还有负的？

Option Explicit

Sub test()
  Dim arr, i, j, k, t, dic, key, p
  Set dic = CreateObject("scripting.dictionary")
  arr = Sheets("总课表").[c7:bp32]
  For i = 3 To UBound(arr, 1) Step 3
    For j = 3 To UBound(arr, 2)
      If Len(arr(i, j)) Then
        If dic.exists(arr(i, j)) Then
          t = dic(arr(i, j))
          ReDim Preserve t(UBound(t) + 4) '
          t(UBound(t) - 3) = arr(i + 1, j) '
          t(UBound(t) - 2) = arr(1, j)
          t(UBound(t) - 1) = arr(i + 2, j)
          t(UBound(t)) = i / 3
          dic(arr(i, j)) = t
        Else
          dic(arr(i, j)) = Array(arr(i + 1, j), arr(1, j), arr(i + 2, j), i / 3)
        End If
      End If
  Next j, i
  With Sheets("安排")
    arr = .Range("a2:h" & .Cells(Rows.Count, "a").End(xlUp).Row + 1)
    For i = 1 To UBound(arr, 1) - 1
      For j = 5 To 7: arr(i, j) = vbNullString: Next
      arr(i, j) = i
    Next
    Call qsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 4)
    For Each key In dic.Keys
      t = dic(key)
      For i = 1 To UBound(arr, 1) - 1
        If arr(i, 4) = key Then p = i: Exit For
      Next
      If i = UBound(arr, 1) Then MsgBox "无法找到课程!": Exit Sub
      For i = 0 To UBound(t) Step 4
        For j = 1 To t(i)
          For k = 5 To 7: arr(p, k) = t(i + k - 4): Next
          p = p + 1
          If arr(p - 1, 4) <> key Then
            Call qsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 8)
            .[a2].Resize(UBound(arr, 1) - 1, UBound(arr, 2) - 1) = arr
            MsgBox key & vbNewLine & "人数不够排！": Exit Sub
          End If
    Next j, i, key
    Call qsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 8)
    .[a2].Resize(UBound(arr, 1) - 1, UBound(arr, 2) - 1) = arr
  End With
End Sub

Function qsort(arr, first, last, left, right, key)
  Dim i As Long, j As Long, k As Long, x, t
  i = first: j = last: x = arr((first + last) / 2, key)
  While i <= j
    While arr(i, key) < x: i = i + 1: Wend
    While x < arr(j, key): j = j - 1: Wend
    If i <= j Then
      For k = left To right
        t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
      Next
      i = i + 1: j = j - 1
    End If
  Wend
  If first < j Then Call qsort(arr, first, j, left, right, key)
  If i < last Then Call qsort(arr, i, last, left, right, key)
End Function

779846526

一把小刀闯天下 发表于 2019-1-17 15:32
'好玩而已，，，

'运行到"政治B"，人数不够，人数还有负的？

谢谢大侠的回贴，你的代码可以安排完所有的人员，但出现了个明显的 计划与需要安排数完全一致的附件修正人数上的错误3.zip (193.17 KB, 下载次数: 10)

2019-1-17 17:26 上传

点击文件名下载附件

问题：同一学员的节次出现了相同的，在同一个节次一人不可能学习2个科目吧

一把小刀闯天下

779846526 发表于 2019-1-17 17:26
谢谢大侠的回贴，你的代码可以安排完所有的人员，但出现了个明显的问题：同一学员的节次出现了相同的，在 ...

'我想简单了。后来换了随机交换，跑了几分钟也没跑出结果，，，
Option Explicit

Sub test()
  Dim arr, i, j, k, t, dic, key, p, a, b
  Set dic = CreateObject("scripting.dictionary")
  arr = Sheets("总课表").[c7:bp32]
  For i = 3 To UBound(arr, 1) Step 3
    For j = 3 To UBound(arr, 2)
      If Len(arr(i, j)) Then
        If dic.exists(arr(i, j)) Then
          t = dic(arr(i, j))
          ReDim Preserve t(UBound(t) + 4) '
          t(UBound(t) - 3) = arr(i + 1, j) '
          t(UBound(t) - 2) = arr(1, j)
          t(UBound(t) - 1) = arr(i + 2, j)
          t(UBound(t)) = i / 3
          dic(arr(i, j)) = t
        Else
          dic(arr(i, j)) = Array(arr(i + 1, j), arr(1, j), arr(i + 2, j), i / 3)
        End If
      End If
  Next j, i
  With Sheets("安排")
    arr = .Range("a2:h" & .Cells(Rows.Count, "a").End(xlUp).Row + 1)
    For i = 1 To UBound(arr, 1) - 1
      For j = 5 To 7: arr(i, j) = vbNullString: Next
      arr(i, j) = i
    Next
    Call qsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 4)
    For Each key In dic.Keys
      t = dic(key)
      For i = 1 To UBound(arr, 1) - 1
        If arr(i, 4) = key Then p = i: Exit For
      Next
      If i = UBound(arr, 1) Then MsgBox "无法找到课程!": Exit Sub
      For i = 0 To UBound(t) Step 4
        For j = 1 To t(i)
          For k = 5 To 7: arr(p, k) = t(i + k - 4): Next
          p = p + 1
          If arr(p - 1, 4) <> key Then
            Call qsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 8)
            .[a2].Resize(UBound(arr, 1) - 1, UBound(arr, 2) - 1) = arr
            MsgBox key & vbNewLine & "人数不够排！": Exit Sub
          End If
    Next j, i, key
    Call qsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 8)
    For i = 1 To UBound(arr, 1) - 1
      For j = i To UBound(arr, 1) - 1
        If arr(j, 1) <> arr(j + 1, 1) Then
          dic.RemoveAll
          For a = i To j
            If dic.exists(arr(a, 7)) Then
              For b = j + 1 To UBound(arr, 1) - 1
                If arr(a, 4) = arr(b, 4) And Not dic.exists(arr(b, 7)) Then
                  For k = 5 To 7
                    t = arr(a, k): arr(a, k) = arr(b, k): arr(b, k) = t
                  Next
                  dic(arr(a, 7)) = a
                  Exit For
                End If
              Next
              If b = UBound(arr, 1) Then MsgBox "无法调整：" & i: Exit Sub
            Else
              dic(arr(a, 7)) = a
            End If
          Next
          i = j: Exit For
        End If
    Next j, i
    .[a2].Resize(UBound(arr, 1) - 1, UBound(arr, 2) - 1) = arr
  End With
End Sub

Function qsort(arr, first, last, left, right, key)
  Dim i As Long, j As Long, k As Long, x, t
  i = first: j = last: x = arr((first + last) / 2, key)
  While i <= j
    While arr(i, key) < x: i = i + 1: Wend
    While x < arr(j, key): j = j - 1: Wend
    If i <= j Then
      For k = left To right
        t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
      Next
      i = i + 1: j = j - 1
    End If
  Wend
  If first < j Then Call qsort(arr, first, j, left, right, key)
  If i < last Then Call qsort(arr, i, last, left, right, key)
End Function

779846526

一把小刀闯天下 发表于 2019-1-17 20:30
'没注意还有这条件，处理了一下，但很容易无解

'无解并不一定真的无解，这问题就变复杂了。你这附件是 ...

谢谢您的帮忙，再次谢谢，测试了下还是有同学员安不同的科目安排到了相同的节次上了

一把小刀闯天下

779846526 发表于 2019-1-17 21:07
谢谢您的帮忙，再次谢谢，测试了下还是有同学员安不同的科目安排到了相同的节次上了

dic(arr(b 7)) = a  '写错了，65已修改，再试一下

应该为 dic(arr(a, 7)) = a

779846526

一把小刀闯天下 发表于 2019-1-17 21:25
dic(arr(b 7)) = a  '写错了，65已修改，再试一下

应该为 dic(arr(a, 7)) = a

谢谢，我把65楼的代码测试了，还有不同科目排了同一节次的