EXCEL VBA排班表

做都做了，顺手水一篇，按需取用。感觉快不记得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