求助排（均衡）值班表

wlianke

结合各位大师的算法，自己胡乱编了一个代码，21个人以内随便排，间隔合理，值勤均匀。在此非常感谢所有提供帮助的大师！代码非常乱，算法也不科学，但已经够用了！有心的大师能否帮助修整代码，成分感激！！！
求助老师们，能否实现以下功能：
一、共14个人参与值班，每天1个人值班。
二、每个周mod周日都进行人员调整，目的是不能让某人老是周六或周日值班，所以，需要每个人都能轮到周六或周日值班
三、每个人的值班的频次要均等，不能有的人值的多，有的人值的少。例如，王聪聪两个月值了四天班，而邢金两个月只值了两三或者三天班。
四、排班周期可以一个月，也可以两个月，也可以三个月，只要大家都能轮一遍。
五、排好班后值完这一轮，最好下一轮可以继续用这个，或者可以重排，但原则还是每个人的值班频次均等。

1. 模块1：
   
2. Sub test() '统计排班情况
   
3. Dim arr, brr(1 To 10000, 1 To 8)
   
4. Dim dic
   
5. Set dic = CreateObject("scripting.dictionary")
   
6. arr = Sheets("排班表").Range("B2:D" & Sheets("排班表").Cells(Rows.Count, "B").End(xlUp).Row)
   
7. For x = 1 To UBound(arr)
   
8. If Not dic.exists(arr(x, 2)) Then Set dic(arr(x, 2)) = CreateObject("scripting.dictionary")
   
9. dic(arr(x, 2))(arr(x, 1)) = dic(arr(x, 2))(arr(x, 1)) + 1
   
10. Next
    
11. brr(1, 1) = "姓名"
    
12. brr(1, 2) = "周一"
    
13. brr(1, 3) = "周二"
    
14. brr(1, 4) = "周三"
    
15. brr(1, 5) = "周四"
    
16. brr(1, 6) = "周五"
    
17. brr(1, 7) = "周六"
    
18. brr(1, 8) = "周日"
    
19. c = 2
    
20. For Each aa In dic.keys
    
21.     brr(c, 1) = aa
    
22.     For Each bb In dic(aa).keys
    
23.         For n = 2 To 8
    
24.             If brr(1, n) = bb Then
    
25.             brr(c, n) = dic(aa)(bb)
    
26.             End If
    
27.         Next
    
28.     Next
    
29.     c = c + 1
    
30. Next
    
31. Sheets("排班情况").[A2].Resize(UBound(brr), UBound(brr, 2)) = brr
    
32. With Sheets("排班情况")
    
33.      With .Range("A1").CurrentRegion
    
34.           .Borders.LineStyle = xlContinuous '加边框
    
35.           .HorizontalAlignment = xlCenter '居中
    
36.      End With
    
37.           .Cells.EntireColumn.AutoFit '列自适应
    
38. End With
    
39. Sheets("排班情况").Activate
    
40. End Sub
    
41. 模块2
    
42. Option Explicit
    
43. Public pbname '排班人员数组
    
44. Public rs As Integer  '参与排班的人数
    
45. Public zqarray '排班周期数组
    
46. Public ksrq As Date  '开始日期
    
47. Public arr '人数大于等于21人时的数组
    
48. Sub pbsub()
    
49. Dim i As Integer, ts As Integer, x As Integer, y As Integer
    
50. pbname = Sheets("基础数据").Range("B2:D" & Sheets("基础数据").Range("B10000").End(xlUp).Row)
    
51. ReDim Preserve pbname(1 To UBound(pbname), 1 To 4)
    
52.     For i = 1 To UBound(pbname)
    
53.         pbname(i, 4) = i - 1
    
54.     Next
    
55. ksrq = Sheets("基础数据").Range("A2")
    
56. rs = UBound(pbname)
    
57. If rs > 21 Then MsgBox "抱歉，暂不支持21人以上的排班！": End
    
58. If rs Mod 4 = 0 Then
    
59.     ts = UBound(pbname) * 7
    
60. Else
    
61.     ts = UBound(pbname) * 2 * 7
    
62. End If
    
63. ReDim crr(1 To ts)
    
64. ReDim zqarray(0 To ts, 1 To 5)
    
65.     zqarray(0, 1) = "日期": zqarray(0, 2) = "星期": zqarray(0, 3) = "姓名": zqarray(0, 4) = "部门": zqarray(0, 5) = "电话"
    
66. If rs Mod 4 = 0 Then
    
67.     For i = 1 To UBound(zqarray)
    
68.         zqarray(i, 1) = ksrq + (i - 1)
    
69.                 zqarray(i, 2) = Format(Weekday(zqarray(i, 1), 1), "aaa")
    
70.                 crr(i) = y
    
71.              For x = 1 To rs
    
72.                  If pbname(x, 4) = crr(i) Then zqarray(i, 3) = pbname(x, 1): zqarray(i, 4) = pbname(x, 2): zqarray(i, 5) = pbname(x, 3)
    
73.              Next x
    
74.         If y < rs - 1 Then y = y + 1 Else y = 0
    
75.     Next
    
76. ElseIf rs = 21 Then
    
77.     Call shiyan
    
78.     For i = 1 To UBound(zqarray)
    
79.         zqarray(i, 1) = ksrq + (i - 1)
    
80.         zqarray(i, 2) = Format(Weekday(zqarray(i, 1), 1), "aaa")
    
81.             For y = 1 To rs
    
82.                 If pbname(y, 4) = arr(i - 1) Then zqarray(i, 3) = pbname(y, 1): zqarray(i, 4) = pbname(y, 2): zqarray(i, 5) = pbname(y, 3)
    
83.             Next
    
84.     Next i
    
85. Else
    
86.     For i = 1 To UBound(zqarray)
    
87.         zqarray(i, 1) = ksrq + (i - 1): crr(i) = (i - 1 + Int((WorksheetFunction.WeekNum(zqarray(i, 1), 2) + 1) / 2) * 2) Mod rs
    
88.         zqarray(i, 2) = Format(Weekday(zqarray(i, 1), 1), "aaa")
    
89.         For x = 1 To rs
    
90.             If pbname(x, 4) = crr(i) Then zqarray(i, 3) = pbname(x, 1): zqarray(i, 4) = pbname(x, 2): zqarray(i, 5) = pbname(x, 3)
    
91.         Next
    
92.     Next
    
93. End If
    
94. Sheets("排班表").UsedRange.Clear 'Contents
    
95. Sheets("排班表").Range("A1").Resize(UBound(zqarray) + 1, UBound(zqarray, 2)) = zqarray
    
96. With Sheets("排班表")
    
97.      With .Range("A1").CurrentRegion
    
98.           .Borders.LineStyle = xlContinuous '加边框
    
99.           .HorizontalAlignment = xlCenter '居中
    
100.      End With
     
101.           .Cells.EntireColumn.AutoFit '列自适应
     
102. End With
     
103. Sheets("排班表").Activate
     
104. End Sub
     
105. 
     
106. Public Sub shiyan()
     
107. Dim cs As Integer, x As Integer, y As Integer, z As Integer, u As Integer, v  As Integer, w As Integer, brr
     
108. ReDim brr(0 To rs - 1)
     
109. For x = 0 To UBound(brr)
     
110.     brr(x) = x
     
111. Next x
     
112. ReDim arr(0 To (UBound(brr) + 1) * 2 * 7 - 1)
     
113. x = 0
     
114. y = 0
     
115. For z = v To (UBound(arr) + 1)
     
116.     For x = w To UBound(brr)
     
117.        arr(v) = brr(x)
     
118.        v = v + 1
     
119.     Next x
     
120.     If UBound(brr) - w < UBound(brr) Then
     
121.         w = (UBound(brr) + 1) - (UBound(brr) + 1 - w) - 1
     
122.        For y = 0 To w
     
123.            arr(v) = brr(y)
     
124.            v = v + 1
     
125.        Next
     
126.        w = w + 1
     
127.     End If
     
128.     w = w + 1
     
129.     If v >= (UBound(arr) + 1) Then GoTo 100
     
130. Next z
     
131. 100:
     
132. End Sub

复制代码

xsy我可以很好

wlianke

xsy我可以很好 发表于 2024-3-30 08:35

您这公式试了一下，值周日的总是值周日，值周六的也总是值周六

山菊花

简单规则轮流：
B15=INDEX(B$1:B$14,MOD(MATCH(B14,B$1:B$14,)+IF(MOD(ROW(),14)=1,2),14)+1)

1245752336

参与一下。我采用了一种比较偷懒的方法，把休息日按人名顺序正向排序，工作日按人名顺序倒序排序。

wlianke

1245752336 发表于 2024-3-30 10:27
参与一下。我采用了一种比较偷懒的方法，把休息日按人名顺序正向排序，工作日按人名顺序倒序排序。

你好，感谢您的帮助，能尽量避免连续值班吗，就是每个人的值班间隔尽可能大于10天以上

wlianke

山菊花 发表于 2024-3-30 10:18
简单规则轮流：
B15=INDEX(B$1:B$14,MOD(MATCH(B14,B$1:B$14,)+IF(MOD(ROW(),14)=1,2),14)+1)

感谢您的帮助

Excel表哥在此

4.1至7.7, 期间98天，其中有28个周末日，70个平时日，14人分，正好平均分配，每人5天平时日期+2天周末日期，按此98天一循环不就达到目的了？

wlianke

Excel表哥在此 发表于 2024-3-30 12:07
4.1至7.7, 期间98天，其中有28个周末日，70个平时日，14人分，正好平均分配，每人5天平时日期+2天周末日期 ...

是的，但是需要避免某个人的值班日间隔太短，所以排起来还是挺麻烦的

Excel表哥在此

wlianke 发表于 2024-3-30 12:14
是的，但是需要避免某个人的值班日间隔太短，所以排起来还是挺麻烦的

这个可以不是那么麻烦的......