一个多维排班问题

zhenkai

笨鸟飞不高 发表于 2024-12-21 12:57

前辈 您这个有excel附件供参考吗？我下载下来调试一下，感谢您关注 测试 录屏展示。我是小白，您给的程序我不知道怎么去运用。

笨鸟飞不高

zhenkai 发表于 2024-12-21 13:39
前辈 您这个有excel附件供参考吗？我下载下来调试一下，感谢您关注 测试 录屏展示。我是小白，您给的程序 ...

排班.zip (30.31 KB, 下载次数: 6)

2024-12-21 13:46 上传

点击文件名下载附件

翁知江安

不好意思，我理解错了。晚上再琢磨一下，看看能不能改进

翁知江安

Sub paiban()
Dim i, j, k, kk, kkk, kkkk, pp, z, zz, aa, q, qq, m, n, p, b, bb, xx, yy, x, y, irow, irow1
Dim ar, br, cr, dr, er
Dim d1, d2 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
irow1 = Sheets("人员").[a1000].End(xlUp).Row
For i = 2 To 10
   d1(i - 1) = Sheets("人员").Cells(i, 1)
Next
For i = 2 To irow1
   d2(i - 1) = Sheets("人员").Cells(i, 1)
Next

irow = Sheets("排班表").[a1000].End(xlUp).Row
ar = Sheets("排班表").Range("a1:d" & irow)
ReDim br(1 To irow - 1, 1 To 5)
ReDim cr(1 To irow - 1, 1 To 5)
ReDim dr(1 To irow - 1, 1 To 5)
For j = 2 To irow
   ar(i, 1) = Format(ar(i, 1), "yyyy/mm/dd")
   ar(i, 2) = WorksheetFunction.Text(ar(i, 2), "aaaa")
  If ar(j, 3) = "节假日" Then
    m = m + 1
    br(m, 1) = j
    For p = 2 To 5
    br(m, p) = ar(j, p - 1)
    Next
    Else
    If ar(j, 3) = "平日" Then
      n = n + 1
      cr(n, 1) = j
      For p = 2 To 5
      cr(n, p) = ar(j, p - 1)
      Next
      Else
      q = q + 1
      dr(q, 1) = j
      For p = 2 To 5
      dr(q, p) = ar(j, p - 1)
      Next
    End If
End If
Next
Sheets("排班表").[f1].Resize(500, 5).ClearContents
k = WorksheetFunction.RandBetween(1, d1.Count)
br(1, 5) = d1((k - 1) Mod 9 + 1)
For x = 2 To m
   xx = xx + 1
   br(x, 5) = d1((k + xx - 1) Mod 9 + 1)
Next

If n >= 28 Then
kk = WorksheetFunction.RandBetween(1, d2.Count)
cr(1, 5) = d2((kk - 1) Mod 28 + 1)
For y = 2 To Int(n / 28) * 28
   yy = yy + 1
   cr(y, 5) = d2((kk + yy - 1) Mod 28 + 1)
Next
End If

If q >= 28 Then
kkk = WorksheetFunction.RandBetween(1, d2.Count)
dr(1, 5) = d2((kkk - 1) Mod 28 + 1)
For z = 2 To Int(q / 28) * 28
   zz = zz + 1
   dr(z, 5) = d2((kkk + zz - 1) Mod 28 + 1)
Next
End If

ReDim er(1 To irow - 1, 1 To 5)
For pp = 1 To n
  If cr(pp, 5) = "" Then
    qq = qq + 1
    For aa = 1 To 4
    er(qq, aa) = cr(pp, aa)
    cr(pp, aa) = ""
    Next
  End If
Next
For pp = 1 To q
  If dr(pp, 5) = "" Then
    qq = qq + 1
    For aa = 1 To 4
    er(qq, aa) = dr(pp, aa)
    dr(pp, aa) = ""
    Next
  End If
Next

kkkk = WorksheetFunction.RandBetween(1, d2.Count)
er(1, 5) = d2((kkkk - 1) Mod 28 + 1)
For b = 2 To qq
   bb = bb + 1
   er(b, 5) = d2((kkkk + bb - 1) Mod 28 + 1)
Next

With Sheets("排班表")
.[a1].Resize(1, 4).Copy Sheets("排班表").[g1]
.[f2].Resize(m, 5) = br
.Cells(m + 2, 6).Resize(Int(n / 28) * 28, 5) = cr
.Cells(m + Int(n / 28) * 28 + 2, 6).Resize(Int(q / 28) * 28, 5) = dr
.Cells(m + Int(n / 28) * 28 + Int(q / 28) * 28 + 2, 6).Resize(qq, 5) = er
.[f1].Resize(irow + 1, 5).Sort key1:=Columns("f"), order1:=xlAscending, Header:=xlYes
.[f1].Resize(500, 1).ClearContents
End With
End Sub

翁知江安

重新修改了一下，总体上差距不大，供参考

yynrzwh

zjwclient

看下是否可以。