而功能-根据变量迭代添加天/月，占每个月的最大天数

Posted 2021-04-08

我还想了解一些VBA代码，因为我还比较陌生。 ：）

问题：创建一个VBA函数，该函数将一个基础日期上的天数或月数迭代地添加到一个“定期”和“截止”日期上。请参考下图。

原始功能有效，但没有解决“ 30日”这样的问题。例如，如果基准日期是30/11/2019，而截止日期是25/08/2020，则它将迭代通过2020年2月，最多只能有28天。在2月迭代中，更改后的内容将变为“ 28/02/2020”，然后在2020年3月迭代到“ 28/03/2020”。

因此，我想保存最大基准'changeday'并将其重新设置为最终的'changedate'。但是，从第一行开始，调整后的日期将返回第一行。最终日期应为“ 30/08/2020”

任何帮助将不胜感激！预先谢谢！

代码＃ver1：

Function getModifiedDate(newdate, cutoff, periodicity)
  While newdate < cutoff
    If periodicity = "Monthly" Then
        newdate = DateAdd("m", 1, newdate)
    ElseIf periodicity = "2-Monthly" Then
        newdate = DateAdd("m", 2, newdate)
    ElseIf periodicity = "Quarterly" Then
        newdate = DateAdd("m", 3, newdate)
    ElseIf periodicity = "6-Monthly" Then
        newdate = DateAdd("m", 6, newdate)
    ElseIf periodicity = "Weekly" Then
        newdate = newdate + 7
    ElseIf periodicity = "Fortnightly" Then
        newdate = newdate + 14

    End If
  Wend
  getModifiedDate = newdate
End Function

代码＃ver2：

Function getModifiedDate(changedate, cutoff, periodicity)
  While changedate < cutoff
    If periodicity = "Monthly" Then
        changeday = Day(changedate)
        changedate = DateAdd("m", 1, changedate)
        lastmonthday = Application.WorksheetFunction.EoMonth(changedate, 0)
            If changeday >= Day(changedate) Then
                changedate = DateSerial(Year(changedate), Month(changedate), changeday)
            End If
    ElseIf periodicity = "2-Monthly" Then
        changeday = Day(changedate)
        changedate = DateAdd("m", 2, changedate)
            If changeday >= Day(changedate) Then
                changedate = DateSerial(Year(changedate), Month(changedate), changeday)
            End If
    ElseIf periodicity = "Quarterly" Then
        changeday = Day(changedate)
        changedate = DateAdd("m", 3, changedate)
            If changeday >= Day(changedate) Then
                    changedate = DateSerial(Year(changedate), Month(changedate), changeday)
                End If
    ElseIf periodicity = "6-Monthly" Then
        changeday = Day(changedate)
        changedate = DateAdd("m", 6, changedate)
            If changeday >= Day(changedate) Then
                changedate = DateSerial(Year(changedate), Month(changedate), changeday)
            End If
    ElseIf periodicity = "Weekly" Then
        changedate = changedate + 7
    ElseIf periodicity = "Fortnightly" Then
        changedate = changedate + 14

    End If
  Wend
  getModifiedDate = changedate
End Function

答案

我建议使用一种不同的算法，在这种算法中，您不必添加一个周期，而是添加适当数量的周期一次全部]。这样，您可以避免出现中间月数没有必要的天数的问题。

您可以通过计算changedate和cutoff之间的“期间差异”，然后检查以确保您的结果不小于cutoff。

如果周期性不是指定类型之一，还应添加检查和结果。可能带有Case Else语句。

例如：

Option Explicit
Function getModifiedDate(changedate As Date, cutoff As Date, periodicity As String) As Date
    Dim L As Long
    Dim dtTemp As Long

'Sanity check
If changedate > cutoff Then
    getModifiedDate = changedate 'or cutoff, depending on what you want
    Exit Function
End If

Select Case periodicity
    Case "Monthly"
        L = DateDiff("m", changedate, cutoff)
        dtTemp = DateAdd("m", L, changedate)
        getModifiedDate = DateAdd("m", L + IIf(dtTemp < cutoff, 1, 0), changedate)
    Case "2-Monthly"
        L = DateDiff("m", changedate, cutoff)  2
        dtTemp = DateAdd("m", L * 2, changedate)
        getModifiedDate = DateAdd("m", L * 2 + IIf(dtTemp < cutoff, 2, 0), changedate)
    Case "6-Monthly"
        L = DateDiff("m", changedate, cutoff)  6
        dtTemp = DateAdd("m", L * 6, changedate)
        getModifiedDate = DateAdd("m", L * 6 + IIf(dtTemp < cutoff, 6, 0), changedate)
    Case "Quarterly"
        L = DateDiff("q", changedate, cutoff)
        dtTemp = DateAdd("q", L, changedate)
        getModifiedDate = DateAdd("q", L + IIf(dtTemp < cutoff, 1, 0), changedate)
    Case "Weekly"
        L = DateDiff("ww", changedate, cutoff)
        dtTemp = DateAdd("ww", L, changedate)
        getModifiedDate = DateAdd("ww", L + IIf(dtTemp < cutoff, 1, 0), changedate)
    Case "Fortnightly"
        L = DateDiff("ww", changedate, cutoff)  2
        dtTemp = DateAdd("ww", L * 2, changedate)
        getModifiedDate = DateAdd("ww", L * 2 + IIf(dtTemp < cutoff, 2, 0), changedate)
End Select

End Function