Question

我试图在Excel VBA上构建一个函数，以获取3月/ 6月/ 9月/星期五的第三个星期三，具体取决于哪个日期接近指定日期。假设今天是6/2/2019，则应返回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月的第三个星期三或之后处理了输入日期，则为IDK，但此代码会将其推到下一个三月的下一个第三个星期三。

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

3 个答案:

算法