VBA查找C列首次出现的今日日期并在上插入行功能失效求解决方法

原有代码故障原因 #

• 查找今日日期时调用的[Today()]是工作表函数写法，VBA 原生应使用Date函数获取当前日期，同时Find方法未指定匹配规则，极易因单元格日期格式与查找值格式不匹配导致查找失败
• 依赖Select、ActiveCell操作，工作表活动单元格变化时会导致执行结果错位
• 插入行后的赋值逻辑存在偏移错误：插入行在目标单元格上方，应使用向上偏移的索引赋值，原有代码会错误覆盖原有目标行的内容

修正后完整代码 #

已内置明日日期匹配插入功能，可直接使用：

Dim cl As Range

' 匹配D列首次出现的Scheduled，上方插入行
Set cl = Range("D:D").Find(What:="Scheduled", LookIn:=xlValues, LookAt:=xlWhole)
If Not cl Is Nothing Then
    cl.EntireRow.Insert
    cl.Offset(-1, -3).Value = "SCHEDULED"
End If

' 匹配D列首次出现的Roadblock，上方插入行
Set cl = Range("D:D").Find(What:="Roadblock", LookIn:=xlValues, LookAt:=xlWhole)
If Not cl Is Nothing Then
    cl.EntireRow.Insert
    cl.Offset(-1, -3).Value = "ROADBLOCKED"
End If
 
' 匹配C列首次出现的今日日期，上方插入行
Set cl = Range("C:C").Find(What:=Date, LookIn:=xlValues, LookAt:=xlWhole)
If Not cl Is Nothing Then
    cl.EntireRow.Insert
    cl.Offset(-1, -2).Value = "DUE TODAY"
End If

' 匹配C列首次出现的明日日期，上方插入行
Set cl = Range("C:C").Find(What:=Date + 1, LookIn:=xlValues, LookAt:=xlWhole)
If Not cl Is Nothing Then
    cl.EntireRow.Insert
    cl.Offset(-1, -2).Value = "DUE TOMORROW"
End If

注意事项 #

如果C列日期带时分秒格式，可将What:=Date替换为What:=DateSerial(Year(Date), Month(Date), Day(Date))，强制匹配日期部分，忽略时分秒的影响。

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