这篇用Excel VBA实现日期高效一键填充（续）是上一篇用Excel VBA实现日期高效一键填充

的完善与优化。

完善和优化的地方

1. 增加了同日期单元格的合并和拆分。
2. 屏蔽系统的提示信息。

完整代码

Sub FillSchedule()
    Dim startDate As Date
    Dim days As Integer
    Dim cfhs As Integer
    Dim j As Integer
    Dim currentDate As Date
    Dim i As Integer, k As Integer, rowOffset As Integer
    Dim currentCell As Range, nextCell As Range
    '检查是否存在合并单元格并拆分
    For Each currentCell In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
        If currentCell.MergeCells Then
            currentCell.MergeCells = False
            currentCell.Resize(1, 1).Value = currentCell.Value
        End If
    Next currentCell
    '清除日期列中标题外的单元格内容
    Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).ClearContents
    '获取开始日期和值班总天数
    startDate = InputBox("请输入开始日期（格式：yyyy-mm-dd）：", "高效工作", Date)
    days = InputBox("请输入值班总天数：", "高效工作", 9)
    cfhs = InputBox("请输入重复填充行数：", "高效工作", 3)
    j = InputBox("请选择是否输入重复值：" & vbNewLine & vbNewLine & "   0=输入唯一值" & vbNewLine & "   1=输入重复值", "高效工作", 1)
    '填充排班表的日期列A列
    Range("A1").Value = "日期" '添加日期列标题
    Range("A2").Value = startDate '填充起始日期
    currentDate = startDate
    For i = 1 To days
        If cfhs = 1 Then
            Range("A" & i + 1).Value = currentDate '逐行填充日期，不重复
        Else
            For k = 0 To cfhs - 1
                rowOffset = (i - 1) * cfhs + k + 2
                If k = 0 Then
                    Range("A" & rowOffset).Value = currentDate '填充唯一值
                Else
                    If rowOffset - j >= 2 Then '确保行数不会超出范围
                        Range("A" & rowOffset).Value = Range("A" & rowOffset - j).Value '填充重复值
                    End If
                End If
            Next k
        End If
        currentDate = currentDate + 1 '日期加1
    Next i
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    '居中排列
    Range("A1").Select
    Range("A1").HorizontalAlignment = xlCenter
    '合并相邻且相同的日期单元格
    For i = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
        Set currentCell = Range("A" & i)
        Set prevCell = Range("A" & i - 1)
        If currentCell.Value = prevCell.Value Then
            Range(prevCell, currentCell).Merge
        End If
    Next i
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

应用场景及延伸

该代码的应用场景包括各种需要生成排班表（后期待编写）的场合，如医院、学校、企业等组织机构的排班安排。它可以帮助用户快速生成排班表，并提高工作效率。如果需要更复杂的排班表，可以根据需要进行修改和扩展该宏的功能。例如，可以添加多个值班人员的名称、岗位等信息，并对不同值班人员进行不同的排班安排。