VBA自适应多种排班计划日期填充

实例需求：某公司有两种不同排班计划

• MWF: 周一周三周五-周一周三周五…
• TTS: 周二周四周六-周二周四周六…

但是数据表中有时会缺少部分日期，为了便于汇总多个部分的数据，现在需要将日期补全，对于补充的日期标记为黄色。

---

先讨论一些如何计算不同排班计划中的下一个有效时间。

• 使用Weekday函数可以返回代表星期x的数字，这个函数支持多种方案，例如：周一开始，周日开始等等。本代码使用周一作为日历周的开始日，即：周一至周日，返回值为1~7。
• 下表中“日期间隔”列统计每个日期和之前相邻日期的间隔天数，可以看出两种排班计划都是按2-2-3的模式再重复。
• 对于TTS排班，除了周二之外，weekday 返回值是日期间隔的两倍
• 对于MWF排班，只需要将 weekday 返回值加一，就可用按照TTS排班处理

MWF	Weekday	日期间隔	TTS	Weekday	日期间隔
2024/1/1	1	2	2024/1/2	2	2
2024/1/3	3	2	2024/1/4	4	2
2024/1/5	5	3	2024/1/6	6	3
2024/1/8	1	2	2024/1/9	2	2
2024/1/10	3	2	2024/1/11	4	2
2024/1/12	5	3	2024/1/13	6	3
2024/1/15	1		2024/1/16	2

---

示例代码如下。

Sub Demo()
    Dim arrRes(), iR As Long, iCnt As Long, i As Long
    Dim iDate As Date, eDate As Date, iOffset As Long
    iR = -1
    With ActiveSheet
        iDate = CDate(.Range("A2"))
        eDate = CDate(.Cells(.Rows.Count, "A").End(xlUp))
    End With
    iOffset = VBA.Weekday(iDate, vbMonday) Mod 2
    Do While iDate <= eDate
        iR = iR + 1
        ReDim Preserve arrRes(iR)
        arrRes(iR) = iDate
        iCnt = (VBA.Weekday(iDate, vbMonday) + iOffset) / 2
        iDate = iDate + IIf(iCnt = 1, 2, iCnt)
    Loop
    For i = 0 To iR
        If Not CLng(CDate(Cells(i + 2, 1).Value)) = CLng(arrRes(i)) Then
            Rows(i + 2).Insert
            Cells(i + 2, 1).Value = arrRes(i)
            Cells(i + 2, 1).Interior.Color = vbYellow
        End If
    Next
End Sub

【代码解析】
第6行代码读取单元格A2，获取开始日期。
第7行代码读取A列最后一个日期，即结束日期。
第9行代码根据日期的星期x，来识别是当前日期序列是TTS还是MWF排班，进而计算一个偏移量，用于计算下一个有效日期。
第10~16行代码从开始日期至结束日期创建日期序列。
第12行代码重新分配结果数组。
第13行代码保存日期。
第14行代码计算下一个有效日期的间隔。
第15行代码计算下一个有效日期。
第17~23行代码循环变量工作表中的数据，插入缺失日期。
第18行代码对比数据表中的日期与结果数组中日期。
第19行代码插入空行。
第20行代码写入增加的日期。
第21行代码设置插入单元格填充色为黄色。