Excel动态日历自动填充关联项目ID的VBA代码扩展咨询

前置约定 #

• 工作表2021 PLRS中，项目ID存放在A列，项目启动日期存放在B列，第1行是表头，有效数据从第2行开始，如果你的实际列位置不同，可自行调整后续代码中的列标识

修改步骤 #

找到原有CalendarMaker宏中如下代码段的位置：

' Turn off gridlines.
ActiveWindow.DisplayGridlines = False
' Protect sheet to prevent overwriting the dates.
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, _
   Scenarios:=True

将以下代码插入到上述两段代码中间：

' 临时取消工作表保护以写入项目ID
ActiveSheet.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
Dim srcSht As Worksheet
Set srcSht = ThisWorkbook.Worksheets("2021 PLRS")
Dim lastRow As Long
' 获取源数据表最后一行有效数据行号
lastRow = srcSht.Cells(srcSht.Rows.Count, "B").End(xlUp).Row
Dim dateCell As Range
' 遍历日历区域所有日期单元格
For Each dateCell In Range("A3:G13")
    ' 判定当前单元格为有效日期数字
    If IsNumeric(dateCell.Value) And dateCell.Value <> "" Then
        ' 拼接当前日期的完整日期值
        curDate = DateSerial(CurYear, CurMonth, dateCell.Value)
        Dim projList As String
        projList = ""
        ' 匹配源表中所有当天启动的项目
        For i = 2 To lastRow
            If srcSht.Cells(i, "B").Value = curDate Then
                ' 多个项目用换行分隔
                If projList <> "" Then projList = projList & Chr(10)
                projList = projList & srcSht.Cells(i, "A").Value
            End If
        Next i
        ' 将项目列表写入日期下方的内容区块
        dateCell.Offset(1, 0).Value = projList
    End If
Next dateCell

修改完成后运行宏，输入指定月份即可自动匹配填充对应日期的所有项目ID，同一天多个项目会自动换行展示。

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