VBA代码优化：人员规划表项目日期区间空白填充及重叠处理

问题背景 #

处理包含员工、周、项目名称三个维度的人员规划文件时，需要实现：

• 填充项目起止日期区间内的空白单元格
• 空白需填充至项目结束日期
• 项目时间重叠时，后续项目名称覆盖旧项目

现有VBA代码存在缺陷：后续项目会被首个项目覆盖（如员工1的Project 2被Project 1覆盖）。

原代码问题分析 #

原代码通常按行从上到下遍历项目，仅填充空白单元格，导致先处理的项目占据单元格后，后续项目无法覆盖重叠区域。

优化后的VBA代码 #

Sub FillProjectsWithPriority()
    Dim ws As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim i As Long
    Dim projName As String
    Dim startCol As Long, endCol As Long
    
    ' 指定目标工作表，可替换为实际表名如Sheets("人员规划")
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    ' 清空所有周列的现有内容，避免旧数据干扰
    ' 假设F列及以后是周维度列，根据实际结构调整
    ws.Range(ws.Cells(2, "F"), ws.Cells(lastRow, lastCol)).ClearContents
    
    ' 从下往上遍历项目行，确保后续项目（表格下方的）优先填充，实现覆盖逻辑
    For i = lastRow To 2 Step -1
        projName = ws.Cells(i, "C").Value ' C列是项目名称，按需调整
        startCol = ws.Cells(i, "D").Value ' D列是起始周对应的列号，按需调整
        endCol = ws.Cells(i, "E").Value ' E列是结束周对应的列号，按需调整
        
        ' 直接填充起止区间，强制覆盖原有内容
        If startCol > 0 And endCol > 0 And startCol <= lastCol And endCol <= lastCol Then
            ws.Range(ws.Cells(i, startCol), ws.Cells(i, endCol)).Value = projName
        End If
    Next i
End Sub

关键优化点 #

1. 清空原有数据：先清除周列区域的所有内容，避免旧数据影响新填充结果
2. 逆序遍历：从表格底部往上处理项目行，确保后续项目（通常是时间靠后的）优先占据单元格，重叠时自动覆盖先处理的旧项目
3. 强制赋值：不再判断单元格是否空白，直接将项目名称写入起止区间，确保目标区域完全被当前项目覆盖

适配调整说明 #

如果你的表格结构不同，需修改代码中以下部分：

• 工作表指定：将ActiveSheet替换为实际工作表名称，如Sheets("人员规划表")
• 列索引：
  • "A"：员工姓名所在列
  • "C"：项目名称所在列
  • "D"/"E"：项目起止周对应的列号列（若起止是日期而非列号，可参考下方日期转列号代码）
• 周列范围："F"改为实际周维度起始列

日期转列号适配代码 #

若项目起止是日期（如第一行是周起始日期），可替换起止列获取逻辑：

Dim startDate As Date, endDate As Date
startDate = ws.Cells(i, "D").Value
endDate = ws.Cells(i, "E").Value

' 查找日期对应的列号
On Error Resume Next
startCol = ws.Rows(1).Find(startDate, LookIn:=xlValues, LookAt:=xlWhole).Column
endCol = ws.Rows(1).Find(endDate, LookIn:=xlValues, LookAt:=xlWhole).Column
On Error GoTo 0

内容的提问来源于stack exchange，提问作者Darius Lai