3月/6月/9月/12月3日

Question

我尝试在Excel上构建一个函数，以获得Mar / Jun /9/ Fri的第三个Wed，这取决于哪个更接近指定的日期。假设今天是2019年6月2日，那么它应该返回6/19/2019，如果是6/19/2019，它应该返回9/18/2019，以此类推。但是，代码不起作用。我已经为您的权限附上了下面的代码。谢谢!

Function NextIMMDate(ByVal dteFromDate As Date) As Date

    Call getNextIMMDate(dteFromDate)

    dayBool = (Day(dteFromDate) < Day(NextIMMDate))
    monthBool = (Month(dteFromDate) = Month(NextIMMDate))

    If (dayBool And monthBool) Or (Not dayBool And Not monthBool) Or (dayBool And Not monthBool) Then
        Call getNextIMMDate(dteFromDate)
    Else
        useDate = DateSerial(Year(dteFromDate), Month(dteFromDate), 21)
        Call getNextIMMDate(useDate)
    End If

End Function

Sub getNextIMMDate()

    Const lngMONTHS_PER_ROLL As Long = 3
    Const lngDAY As Long = 20

    Dim lngMonth As Long
    Dim NextIMMDate As Date

'    dteFromDate = Range("B13")

    lngMonth = -Int((-Month(dteFromDate) - IIf(Day(dteFromDate) > lngDAY, 1, 0)) _
                    / lngMONTHS_PER_ROLL) * lngMONTHS_PER_ROLL

    NextDate = DateSerial(Year(dteFromDate), lngMonth, lngDAY)

    If Weekday(NextDate) = vbWednesday Then
        lngROLL_DAY = 20
    ElseIf Weekday(NextDate) = vbMonday Then
        lngROLL_DAY = 15
    ElseIf Weekday(NextDate) = vbTuesday Then
        lngROLL_DAY = 21
    ElseIf Weekday(NextDate) = vbThursday Then
        lngROLL_DAY = 19
    ElseIf Weekday(NextDate) = vbFriday Then
        lngROLL_DAY = 18
    ElseIf Weekday(NextDate) = vbSaturday Then
        lngROLL_DAY = 17
    ElseIf Weekday(NextDate) = vbSunday Then
        lngROLL_DAY = 16
    End If

    NextIMMDate = DateSerial(Year(dteFromDate), lngMonth, lngROLL_DAY)

'    Range("B31") = NextIMMDate

End Sub

​

​

Answer 1

这可能需要一些调整，但它应该让你走上正确的道路，我想。我使用了vbaexpress.com的一个函数，老实说，它完成了大部分工作。我的职责只是处理你的逻辑。

Public Function NextIMMDate(ByVal dteFromDate As Date) As Date

Const nthPosition As Long = 3 'Third week
Const dayIndex As Long = 4 'Wednesday
Dim targetYear As Long

Dim X As Long
Dim arrMonths(1 To 4) As Long: For X = 1 To 4: arrMonths(X) = X * 3: Next X
Dim arrDates(1 To 4) As Date

targetYear = Year(dteFromDate)

For X = LBound(arrMonths) To UBound(arrMonths)
    If X = UBound(arrMonths) Then
        'handle next year?
        arrDates(X) = NthWeekday(nthPosition, dayIndex, 3, targetYear + 1)
    Else
        arrDates(X) = NthWeekday(nthPosition, dayIndex, arrMonths(X), targetYear)
    End If

    If arrDates(X) > dteFromDate Then
        NextIMMDate = arrDates(X)
        Exit For
    End If
Next X

End Function

Public Function NthWeekday(Position, dayIndex As Long, targetMonth As Long, Optional targetYear As Long)
     'Source: http://www.vbaexpress.com/kb/getarticle.php?kb_id=814
     '****************************************************************

     ' Returns any arbitrary weekday (the "Nth" weekday) of a given month
     ' Position is the weekday's position in the month.  Must be a number 1-5, or the letter L (last)
     ' DayIndex is weekday: 1=Sunday, 2=Monday, ..., 7=Saturday
     ' TargetMonth is the month the date is in: 1=Jan, 2=Feb, ..., 12=Dec
     ' If TargetYear is omitted, year for current system date/time is used

     ' This function as written supports Excel.  To support Access, replace instances of
     ' CVErr(xlErrValue) with Null.  To use with other VBA-supported applications or with VB,
     ' substitute a similar value

    Dim FirstDate As Date

     ' Validate DayIndex
    If dayIndex < 1 Or dayIndex > 7 Then
        NthWeekday = CVErr(xlErrValue)
        Exit Function
    End If

    If targetYear = 0 Then targetYear = Year(Now)

    Select Case Position

         'Validate Position
    Case 1, 2, 3, 4, 5, "L", "l"

         ' Determine date for first of month
        FirstDate = DateSerial(targetYear, targetMonth, 1)

         ' Find first instance of our targeted weekday in the month
        If Weekday(FirstDate, vbSunday) < dayIndex Then
            FirstDate = FirstDate + (dayIndex - Weekday(FirstDate, vbSunday))
        ElseIf Weekday(FirstDate, vbSunday) > dayIndex Then
            FirstDate = FirstDate + (dayIndex + 7 - Weekday(FirstDate, vbSunday))
        End If

         ' Find the Nth instance.  If Position is not numeric, then it must be "L" for last.
         ' In that case, loop to find last instance of the month (could be the 4th or the 5th)
        If IsNumeric(Position) Then
            NthWeekday = FirstDate + (Position - 1) * 7
            If Month(NthWeekday) <> Month(FirstDate) Then NthWeekday = CVErr(xlErrValue)
        Else
            NthWeekday = FirstDate
            Do Until Month(NthWeekday) <> Month(NthWeekday + 7)
                NthWeekday = NthWeekday + 7
            Loop
        End If

         ' This only comes into play if the user supplied an invalid Position argument
    Case Else
        NthWeekday = CVErr(xlErrValue)
    End Select
End Function

Answer 2

您可以使用工作表公式来完成此操作：

=IF(A1<EDATE(A1-DAY(A1)+1,2-MOD(MONTH(A1)-1,3))+21-WEEKDAY(EDATE(A1-DAY(A1)+1,2-MOD(MONTH(A1)-1,3))+3),
EDATE(A1-DAY(A1)+1,2-MOD(MONTH(A1)-1,3))+21-WEEKDAY(EDATE(A1-DAY(A1)+1,2-MOD(MONTH(A1)-1,3))+3),
EDATE(A1-DAY(A1)+1,5-MOD(MONTH(A1)-1,3))+21-WEEKDAY(EDATE(A1-DAY(A1)+1,5-MOD(MONTH(A1)-1,3))+3))

算法

• 计算下一个(或当前)一个月的第一个季度：

EDATE(A1-DAY(A1)+1,2-MOD(MONTH(A1)-1,3))
                   ^ (change to 5 for three months later)

• 计算那个月的第三个星期三：

+21-WEEKDAY(EDATE(A1-DAY(A1)+1,2-MOD(MONTH(A1)-1,3))+3)

• 如果原始日期小于计算日期，则使用该日期，否则添加三个月并计算适当的第三个星期三。

​

​

Answer 3

构建一个‘第三个星期三季度’的数组，并使用工作表的匹配函数从输入日期找到合适的一个。

Option Explicit

Function NextThirdWednesdayQuarter(dt As Long)

    Dim i As Long, m As Long, y As Long
    ReDim dts(0) As Variant

    'building the 'third Wednesday' doesn't take long
    'you should never need more than Mar, Jun, Sep, Dec for
    'the current year and the next year of input date
    'descending order for the worksheet match function
    For y = Year(dt) + 1 To Year(dt) Step -1
        'for Mar, Jun, Sep, Dec
        For m = 12 To 3 Step -3
            'third Wednesday in m and y
            dts(UBound(dts)) = CLng(DateSerial(y, m, 22 - Weekday(DateSerial(y, m, 0), vbWednesday)))
            'make room for next
            ReDim Preserve dts(UBound(dts) + 1)
        Next m
    Next y

    'remove last unused array element
    ReDim Preserve dts(UBound(dts) - 1)

    'add noon to input date so equals won't match
    'worksheet's Match in descending order gives position of date from array
    NextThirdWednesdayQuarter = dts(Application.Match(dt + 0.5, dts, -1) - 1)

    'don't forget to format the UDF worksheet cell as a date

End Function

如果您自己的代码在12月的第三个星期三或之后处理输入日期，那么这个代码将在接下来的三月将其推送到下一个第三个星期三。