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

咔片PPT · AI自动生成演示文稿，模板丰富、排版精美讯飞智文 · 一键生成PPT和Word，高效应对学习与办公

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

的完善与优化。

完善和优化的地方

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

完整代码

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