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