请求各位老师协助，如何实现不重复的随机排班。

si蠢

各位老师好，

我已经做了想下图一样的，按照每个科室要求人数不同把每个人进行了随机的排班，但是不知道怎样能够让每次排班都不重复。

具体情况如下：

现有198名实习生（实习生可能增加人数不定），需要随机排班到41个科室（后续科室可能增加），且每个科室接受的人数不相同，每个周期排一次班，但又要保证每个人本周期排班与上一个周期的排班不重复，为不同的科室。

如下图所示，A列是实习生名单，F列是科室，G列是每个科室要求的人数，现在已经实现了按人数随机排序，但没想出怎样可以实现相连的两次不重复。还请各位老师帮忙，思路或者vba，非常感谢。

牛掰

但没想出怎样可以实现相连的两次不重复，这句话没理解楼主说的是啥

si蠢

牛掰 发表于 2021-1-26 17:20
但没想出怎样可以实现相连的两次不重复，这句话没理解楼主说的是啥

不好意思，说的有点绕，意思就是：
每个周期都要排班，但每个人本周期的排班与上一个周期的排班不重复，比如图片显示的张2，上个周期是“内分泌科”的，那么本次排班就不能同样是“内分泌科”

宝贝晶晶

与以前各期排班科室都不会重

liulang0808

Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    Set dd = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    [a1].CurrentRegion.Offset(1, 2).ClearContents
    arr = [a1].CurrentRegion
    brr = [p1].CurrentRegion
    For i = 3 To UBound(arr, 2)
        d.RemoveAll
        For j = 2 To UBound(brr)
            d(brr(j, 1)) = brr(j, 2)
        Next j
        For j = 2 To UBound(arr)
            dd(j) = j
        Next j
        For Each k In d.keys
            sm = d(k)
l1:
            If sm > 0 Then
                x = WorksheetFunction.RandBetween(0, dd.Count - 1)
                r = dd.keys()(x)
                If k <> arr(r, i - 1) Then
                    arr(r, i) = k
                    dd.Remove r
                    sm = sm - 1
                End If
                GoTo l1
            End If
        Next k
    Next i
    [a1].CurrentRegion = arr
    Application.ScreenUpdating = True
End Sub

liulang0808

看看是否能满足需求。。。

si蠢

宝贝晶晶 发表于 2021-1-26 20:35
与以前各期排班科室都不会重

老师，可以用的，还增加了一列状态的判断，真贴心。
但是目前遇到一个问题，就是我想在C列之前插入两列填写人员的一列基本信息，然后代码里，做了以下的修改：
If brr(i, 5) = "正常" Then
      For j = 6 To UBound(brr, 2)

运行以后卡死了...

宝贝晶晶

si蠢 发表于 2021-1-27 10:26
老师，可以用的，还增加了一列状态的判断，真贴心。
但是目前遇到一个问题，就是我想在C列之前插入两列 ...

Sub pb()
  Application.ScreenUpdating = 0
  brr = Sheet1.Range("A1").CurrentRegion
  Set dic1 = CreateObject("scripting.dictionary")
  For i = 2 To UBound(brr)
    If brr(i, 5) = "正常" Then
      For j = 6 To UBound(brr, 2)
        If brr(i, j) <> "" Then
          dic1(brr(i, 2)) = dic1(brr(i, 2)) & "@" & brr(i, j)
        Else
          Exit For
        End If
      Next
    End If
  Next
  c = Sheet1.Range("ZZ2").End(1).Column + 1
100:
  arr = Sheet2.Range("A1").CurrentRegion
  Set dic = CreateObject("scripting.dictionary")
  For i = 2 To UBound(arr)
    dic(arr(i, 1)) = arr(i, 2)
  Next
  k = dic.keys
  For i = 2 To UBound(brr)
    If brr(i, 5) = "正常" Then
      For j = 0 To UBound(k)
        If dic(k(j)) > 0 And Not InStr(dic1(brr(i, 2)), k(j)) > 0 Then
          brr(i, c) = k(j)
          dic(k(j)) = dic(k(j)) - 1
          Exit For
        End If
      Next
      If brr(i, c) = "" Then
        Application.Calculate
        排序
        GoTo 100:
      End If
    End If
  Next
  Sheet1.Range("A1").Resize(UBound(brr), UBound(brr, 2)) = brr
  Application.ScreenUpdating = 1
End Sub

si蠢

宝贝晶晶 发表于 2021-1-27 11:52
Sub pb()
  Application.ScreenUpdating = 0
  brr = Sheet1.Range("A1").CurrentRegion

老师，感谢您。但刚刚领导给了新的要求，就是总共排班8-10次，每一次都不能重复，之前已经排了6次班了，只需要再随机排2次班，这两次的班不能是之前已经排到过的科室。
哎，实在非常抱歉，我这边之前没有仔细跟领导沟通，导致又一次修改需求，抱歉抱歉。

我已经将之前的排班情况附上了，要麻烦老师再帮忙修改一下，辛苦了。

宝贝晶晶

si蠢 发表于 2021-1-27 13:51
老师，感谢您。但刚刚领导给了新的要求，就是总共排班8-10次，每一次都不能重复，之前已经排了6次班了， ...

标题行加上周期7、周期8……，代码不用修改