实例需求：某公司有两种不同排班计划
- 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 LongDim iDate As Date, eDate As Date, iOffset As LongiR = -1With ActiveSheetiDate = CDate(.Range("A2"))eDate = CDate(.Cells(.Rows.Count, "A").End(xlUp))End WithiOffset = VBA.Weekday(iDate, vbMonday) Mod 2Do While iDate <= eDateiR = iR + 1ReDim Preserve arrRes(iR)arrRes(iR) = iDateiCnt = (VBA.Weekday(iDate, vbMonday) + iOffset) / 2iDate = iDate + IIf(iCnt = 1, 2, iCnt)LoopFor i = 0 To iRIf Not CLng(CDate(Cells(i + 2, 1).Value)) = CLng(arrRes(i)) ThenRows(i + 2).InsertCells(i + 2, 1).Value = arrRes(i)Cells(i + 2, 1).Interior.Color = vbYellowEnd IfNext
End Sub
【代码解析】
第6行代码读取单元格A2，获取开始日期。
第7行代码读取A列最后一个日期，即结束日期。
第9行代码根据日期的星期x，来识别是当前日期序列是TTS还是MWF排班，进而计算一个偏移量，用于计算下一个有效日期。
第10~16行代码从开始日期至结束日期创建日期序列。
第12行代码重新分配结果数组。
第13行代码保存日期。
第14行代码计算下一个有效日期的间隔。
第15行代码计算下一个有效日期。
第17~23行代码循环变量工作表中的数据，插入缺失日期。
第18行代码对比数据表中的日期与结果数组中日期。
第19行代码插入空行。
第20行代码写入增加的日期。
第21行代码设置插入单元格填充色为黄色。
