如何用VBA补全特定工作日的缺失考勤日期并高亮新增行？

• 员工分为两类排班：周一/周三/周五（MWF）、周二/周四/周六（TThS）
• 通过VBA宏补全员工考勤列表中对应排班工作日的缺失日期，插入为新行（保留原有日期列的关联信息）
• 忽略员工的非排班出勤记录，仅按排班规则补全
• 新增行需要高亮显示
• 建议使用Workday.intl函数，通过参数"0101011"（对应MWF）或"1010101"（对应TThS）指定工作日

Sub FillDays()
    Dim dict As New Collection, cl As Range, arr, cur, nxt, mst
    arr = Split(("3 5 7"))
    For cur = 0 To UBound(arr)
        dict.Add cur, arr(cur)       'make the dict name:index, key = name, e.g. "Sunday":0 to get the index by name
    Next
    
    Set cl = ActiveCell   'get the start cell
    Do While True
        cur = cl.Text     'get the text from the current cell
        cur = Weekday(c1)
        Set cl = cl.Offset(1)           'move to the next cell
        nxt = cl.Text    'get the text from the next cell
        nxt = Weekday(nxt)
        On Error Resume Next
        cur = dict(cur + 3)       'get the index of the day of the week from the current cell
        nxt = dict(nxt + 3)       'get the index of the day of the week from the next cell
        MsgBox nxt
        'if the cells do not contain the day of the week or is empty >> exit
        If cur = "" Or nxt = "" Or Err.Number <> 0 Then Exit Do
        On Error GoTo 0
        mst = (cur + 1) Mod 3   'calculate the proper index for the next cell
        MsgBox mst
        If mst <> nxt Then      'if expected weekday <> next weekday
            'add the expected weekday and shift to the next cell
            cl.EntireRow.Insert ' side effect: shifts the cl to the next row
            Set cl = cl.Offset(-1)  'compensate for the side effect
            cl.Value = WorksheetFunction.Proper(arr(mst))   'Capitalized name
            If mst = 1 Then cl.Offset(, 1) = "New"  'a new cell with value "Monday" is created
            cl.Resize(, 2).Font.Bold = True 'debug
        End If
    Loop
End Sub

核心思路 #

1. 指定员工排班类型，匹配Workday.intl的工作日参数
2. 从下往上遍历考勤日期，避免插入行打乱索引顺序
3. 跳过非排班日期的记录，仅处理符合排班规则的日期
4. 计算当前日期的下一个排班工作日，对比下一条记录日期，缺失则插入新行并高亮

Sub FillMissingShiftDays()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long
    Dim currentDate As Date, nextShiftDate As Date
    Dim nextRecordDate As Date
    Dim shiftPattern As String
    Dim shiftType As VbMsgBoxResult
    
    ' 选择当前员工的排班类型
    shiftType = MsgBox("选择员工排班类型：" & vbCrLf & vbCrLf & _
                      "是 = 周一/周三/周五 (MWF)" & vbCrLf & _
                      "否 = 周二/周四/周六 (TThS)", vbYesNo + vbQuestion)
    
    ' 匹配Workday.intl的工作日参数（0=工作日，1=休息日，顺序为周日到周六）
    shiftPattern = IIf(shiftType = vbYes, "0101011", "1010101")
    
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 从下往上遍历，避免插入行影响索引
    i = lastRow
    Do While i > 1
        currentDate = ws.Cells(i, "A").Value
        
        ' 跳过非排班日期的记录
        Select Case Weekday(currentDate, vbMonday) ' vbMonday：周一=1，周二=2...周六=6
            Case 1, 3, 5
                If shiftPattern = "1010101" Then i = i - 1: Continue Do
            Case 2, 4, 6
                If shiftPattern = "0101011" Then i = i - 1: Continue Do
        End Select
        
        ' 计算下一个排班工作日
        nextShiftDate = WorksheetFunction.Workday_Intl(currentDate, 1, shiftPattern)
        nextRecordDate = ws.Cells(i - 1, "A").Value
        
        ' 循环插入所有缺失的排班日期行
        Do While nextRecordDate > nextShiftDate
            ws.Rows(i).Insert Shift:=xlDown
            ws.Cells(i, "A").Value = nextShiftDate
            ' 高亮新增行（黄色填充）
            ws.Rows(i).Interior.ColorIndex = 6
            
            ' 更新下一个待检查的排班日期
            nextShiftDate = WorksheetFunction.Workday_Intl(nextShiftDate, 1, shiftPattern)
            lastRow = lastRow + 1
        Loop
        
        i = i - 1
    Loop
    
    MsgBox "缺失排班日期已补全！", vbInformation
End Sub

使用说明 #

• 确保考勤日期存储在A列，且为标准日期格式
• 运行宏时根据员工排班类型选择对应选项
• 新增的缺失日期行将以黄色填充高亮显示

内容的提问来源于stack exchange，提问作者Rateb TM