VBA日期序列逻辑异常：成本校验脚本未返回预期结果求助

问题背景 #

多次编写VBA代码实现日期遍历与成本校验，但脚本返回结果始终和手动计算不一致。

需求目标 #

需返回两项输出：

1. 一组符合条件的起始日期和结束日期
2. 文本形式的cost check结果（Yes/No）

具体规则 #

• 起始日期范围：从01/10/2025（系统为dd/mm/yyyy格式）按月步进，直到01/11/2026，序列为：01/10/2025、01/11/2025……01/11/2026
• 结束日期规则：初始值为01/01/2032，可按季度（3个月）回退，最多回退8个季度（2年），序列为：01/01/2032、01/10/2031……01/01/2030
• 成本校验逻辑：每一对起始/结束日期对应计算成本，若成本≤阈值，cost check返回Yes；反之返回No（成本计算与校验已在工作表中实现，只需读取Check_Cost单元格的Yes/No结果）
• 执行逻辑：从初始结束日期开始，逐个遍历所有起始日期；若找到cost check为Yes的组合，立即终止并返回结果；若当前结束日期下所有起始日期均返回No，则将结束日期回退3个月，重新遍历所有起始日期，直到找到符合条件的组合或达到最大回退次数

当前使用的VBA代码 #

Sub CheckdateCost()

begin_date = WorksheetFunction.Date (2025,10,1)
end_date = WorksheetFunction.Date (2032,1,1)
nb_quarters_backward_min = 0
Do While Worksheets("Sheet1").Range("Check_Cost").Value = "No" And nb_quarters_backward_min <= 8
   nb_month_forward_min = 0
   Do While Worksheets("Sheet1").Range("Check_Cost").Value = "No" And nb_month_forward_min <= 12
      begin_date = WorksheetFunction.EDate(begin_date, nb_month_forward_min)
      Worksheets("Sheet1").Range("Begin_Date_OK").Value = begin_date
      nb_month_forward_min = nb_month_forward_min + 1
   Loop     
   nb_quarters_backward_min = nb_quarters_backward_min + 1
   end_date = WorksheetFunction.EDate(end_date, -3 * nb_quarters_backward_min)
   Worksheets("Sheet1").Range("End_Date_OK").Value = end_date
Loop
Worksheets("Sheet1").Range("Begin_Date_OK").Value = begin_date
Worksheets("Sheet1").Range("End_Date_OK").Value = end_date

End Sub

代码问题分析与修正 #

原代码存在多个逻辑错误，导致结果不符合预期：

1. 起始日期累加错误：内层循环中每次调用EDate(begin_date, nb_month_forward_min)会基于已修改的begin_date再次累加，导致日期跳变混乱，正确做法是从初始起始日期重新计算步进后的日期。
2. 结束日期回退逻辑错误：原代码用-3 * nb_quarters_backward_min计算回退，第一次回退3个月，第二次回退6个月，回退幅度越来越大，而非每次固定回退3个月。
3. 循环条件判断时机错误：内层循环一开始就判断Check_Cost的值，但此时还未设置起始/结束日期并触发成本计算，逻辑判断滞后。
4. 未重置起始日期：内层循环结束后begin_date已被修改，下次遍历起始日期时未重置回初始值。

修正后的VBA代码 #

Sub CheckdateCost()
    Dim startInitial As Date
    Dim endCurrent As Date
    Dim quarterBackCount As Integer
    Dim monthStepCount As Integer
    
    ' 初始化起始日期（01/10/2025）和结束日期（01/01/2032）
    startInitial = DateSerial(2025, 10, 1)
    endCurrent = DateSerial(2032, 1, 1)
    
    ' 设置初始结束日期到工作表
    Worksheets("Sheet1").Range("End_Date_OK").Value = endCurrent
    
    quarterBackCount = 0
    Do While quarterBackCount <= 8
        ' 重置起始日期步进计数，开始遍历所有起始日期
        monthStepCount = 0
        Do While monthStepCount <= 12
            ' 基于初始起始日期计算当前步进后的日期
            Dim currentStart As Date
            currentStart = DateAdd("m", monthStepCount, startInitial)
            
            ' 更新工作表中的起始日期
            Worksheets("Sheet1").Range("Begin_Date_OK").Value = currentStart
            
            ' 强制刷新工作表，确保成本计算完成
            Application.Calculate
            
            ' 检查成本校验结果，符合条件则直接退出
            If Worksheets("Sheet1").Range("Check_Cost").Value = "Yes" Then
                Exit Sub
            End If
            
            monthStepCount = monthStepCount + 1
        Loop
        
        ' 当前结束日期下无符合条件的起始日期，回退一个季度
        endCurrent = DateAdd("m", -3, endCurrent)
        Worksheets("Sheet1").Range("End_Date_OK").Value = endCurrent
        
        quarterBackCount = quarterBackCount + 1
    Loop
    
    ' 遍历完所有可能仍未找到结果，设置最后一次的日期值
    Worksheets("Sheet1").Range("Begin_Date_OK").Value = DateAdd("m", 12, startInitial)
    Worksheets("Sheet1").Range("End_Date_OK").Value = endCurrent
End Sub

修正点说明 #

• 使用VBA原生DateSerial替代工作表函数，避免不必要的跨对象调用
• 每次遍历起始日期时，从初始值通过DateAdd计算步进日期，保证序列准确
• 结束日期每次固定回退3个月，符合季度回退的要求
• 添加Application.Calculate强制刷新工作表，确保成本计算在校验前完成
• 找到符合条件的结果立即退出，匹配需求中的终止逻辑
• 明确变量类型，提升代码可读性与稳定性

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