做都做了,顺手水一篇,按需取用。感觉快不记得vb长啥样了。
用法:i 列填充人员并选择年份月份(受打印范围限制,最多15个人,可以根据实际需要修改)。效果:自动按名单一人一天排班,并统计当月值班总天数。
建议给F1, G1设置数据有效性,限制输入范围,也方便鼠标操作。
Private Sub Worksheet_Change(ByVal Target As Range)
'只有F1, G1修改年、月的时候才会开始排
If Target.Row > 1 Or Target.Column < 6 Or Target.Column > 7 Then Exit Sub
Dim persons As New Collection, workingdays() As Integer
Dim intYear As Integer, intMonth As Integer
Dim strYear As String, strMonth As String
strYear = Cells(1, 6)
strMonth = Replace(Cells(1, 7), "月", "")
'年份和月份出现非数字就退出
'F1, G1已经做了有效性验证,这儿的判断不是必需的
Dim reg As Object
Set reg = CreateObject("VBScript.Regexp")
reg.Pattern = "\D"
If reg.test(strYear) Or reg.test(strMonth) Then Exit Sub
intYear = Int(strYear)
intMonth = Int(strMonth) '年份超过2050就退出,月份非法也退出
If intYear < 2023 Or intYear > 2050 Or intMonth < 1 Or intMonth > 12 Then Exit Sub
'读取值班人员名单
Dim rowNo As Integer, person As String
For rowNo = 2 To 16
Cells(rowNo, 10) = "" '清零统计数据
person = Cells(rowNo, 9)
If person <> "" Then persons.Add person
Next
ReDim workingdays(persons.Count)
'计算月历第1个单元格,周日计为每周第1天
Dim firstday As Date, monthStart As Date
monthStart = CDate(intYear & "/" & intMonth & "/1")
firstday = DateAdd("d", 1 - Weekday(monthStart, vbSunday), monthStart)
'排班
Dim baseDate As Date, i As Integer
baseDate = CDate("2000/1/1") '基准日期,可以设为任意一天:
'值班日减去基准日,相差的天数除以人数,余数即为人员编号
For i = 1 To 49
Dim col As Integer, curDate As Date, idx As Integer
curDate = DateAdd("d", i - 1, firstday)
idx = DateDiff("d", baseDate, curDate) Mod persons.Count
'3-16行,奇数行日期,偶数行值班人
col = (i Mod 7 + 6) Mod 7 + 1 '把1234560转为1234567
With Cells(Int((i - 1) / 7) * 2 + 3, col)
.Value = Format(curDate, "mm月dd日")
.Font.ColorIndex = IIf(month(curDate) = intMonth, 16, 15)
End With
With Cells(Int((i - 1) / 7) * 2 + 4, col)
.Value = persons(idx + 1)
.Font.ColorIndex = IIf(month(curDate) = intMonth, 23, 15)
.Font.Bold = month(curDate) = intMonth
End With
'统计当月班次
If month(curDate) = intMonth Then workingdays(idx) = workingdays(idx) + 1
Next i
'显示班次统计结果
For rowNo = 2 To 1 + persons.Count
Cells(rowNo, 10) = workingdays(rowNo - 2)
Next rowNo
End Sub