在for循环VBA中建立一个带有日期的列表

Question

我正在尝试构建一个循环来打印每个月的第 15 天和最后一天的列表。列表的开始日期将取决于当前日期 (num_day)，而此类列表的长度将取决于给定的 N 数。

例如，如果今天是 30/07/2021（dd/mm/yyyy 格式），并且 N = 5，则列表应如下所示：

• 31/07/2021、15/08/2021、31/08/2021、15/09/2021、30/09/2021

我当前的 VBA 代码如下：

Sub print_dates()
    
    N = 9
    For i = 0 To N - 1
        
        curr_day = DateAdd("m", i, Date)
        num_day = Format(Date, "dd")
        
        If num_day <= 15 Then
            If i Mod 2 = 0 Then
                print_day = "15/" & Format(curr_day, "mm") & "/" & Format(curr_day, "yyyy")
            Else
                print_day = DateSerial(Year(curr_day), Month(curr_day), 0)
            End If
        Else
            If i Mod 2 = 0 Then
                print_day = DateSerial(Year(curr_day), Month(curr_day), 0)
            Else
                print_day = "15/" & Format(curr_day, "mm") & "/" & Format(curr_day, "yyyy")
            End If
        End If
        
    Debug.Print print_day
        
    Next i

End Sub

使用我当前的代码，列表的结果是：

• 2021 年 6 月 30 日
• 15/08/2021
• 31/08/2021
• 15/10/2021
• 2021 年 10 月 31 日
• 15/12/2021
• 2021 年 12 月 31 日
• 15/02/2022
• 28/02/2022

代码将跳过奇数月份（7、9、11 等）。此外，该列表从上个月的最后一天开始。 对如何达到预期结果有什么建议吗？

非常感谢。

Answer 1

还有一个：

Sub print_dates()
    Dim dt As Date, i As Long
    dt = Date
    For i = 1 To 10
        dt = NextDate(dt)
        Debug.Print dt
    Next i
End Sub

'next date either 15th or last day of month
Function NextDate(ByVal dt As Date)
    Dim d As Long, ld As Long, m As Long, y As Long
    d = Day(dt)
    m = Month(dt)
    y = Year(dt)
    ld = Day(Application.EoMonth(dt, 0)) 'last day of the month
    
    NextDate = IIf(d < 15, DateSerial(y, m, 15), _
               IIf(d < ld, DateSerial(y, m, ld), DateAdd("d", 15, dt)))
End Function

Answer 2

下面的函数将返回你想要的真实日期数组中的列表。

Function DateList(ByVal Dstart As Date, _
                  ByVal Months As Integer) As Date()
    ' 300
    
    Dim Fun()       As Date                 ' list of dates
    Dim i           As Long                 ' index of Fun()
    Dim NextDate    As Date
    Dim n           As Integer              ' loop counter: Months
    
    ReDim Fun(1 To Months * 2)
    If Day(Dstart) < 15 Then
        i = 1
        Fun(i) = DateSerial(Year(Dstart), Month(Dstart), 15)
    End If
    NextDate = DateSerial(Year(Dstart), Month(Dstart) + 1, 1)
    For n = 1 To Months
        i = i + 1
        Fun(i) = NextDate - 1
        If i < UBound(Fun) Then
            i = i + 1
            Fun(i) = DateAdd("d", 14, NextDate)
            NextDate = DateAdd("m", 1, NextDate)
        End If
    Next n
    DateList = Fun
End Function

该函数有两个参数。第一个日期和年数。第一个日期不必是 ultimo 或 15 日，因为该函数将确定下一个可用日期。因此，您可以从程序中调用该函数，如下所示。

Private Sub Test_PrintDates()
    ' 300
    
    Dim MyList()  As Date
    Dim f           As Long
    
    MyList = DateList(Date + 2, 3)
    For f = LBound(MyList) To UBound(MyList)
        Debug.Print Format(MyList(f), "ddd, mmmm dd, yyyy")
    Next f
End Sub

如您所见，我使用Date + 2 作为第一个日期 (Dstart) 来测试各种开始日期。结果列表可以以任何有效的日期格式打印，如上所示。

Answer 3

这样的东西会更好吗？

Sub print_dates()
Dim N As Long, num_day As Long
Dim curr_day As String, print_day As String

    N = 5
    For i = 1 To N / 2 + 0.5 Step 0.5 '<- Half step with compensation to N
        
        curr_day = DateAdd("m", i, Date)
        num_day = Format(Date, "dd")
        
        If num_day <= 15 Then
            If Int(i) / i = 1 Then '<- check for whole numbers instead
                print_day = "15/" & Format(curr_day, "mm") & "/" & Format(curr_day, "yyyy")
            Else
                curr_day = DateAdd("m", i + 1, Date) '<- random fix
                print_day = DateSerial(Year(curr_day), Month(curr_day), 0)
            End If
        Else
            If Int(i) / i = 1 Then '<- same change here
                print_day = DateSerial(Year(curr_day), Month(curr_day), 0)
            Else
                print_day = "15/" & Format(curr_day, "mm") & "/" & Format(curr_day, "yyyy")
            End If
        End If
        
    Debug.Print print_day
        
    Next i

End Sub

Answer 4

下面是一个数组函数。

Option Explicit
Function HalfMonthDateSeries(myDate As Date, count As Long)
'Array (Contrl+Shift+Enter CSE) function
'returns one dimensional array of dateserial 15th and EOM from myDate
'While entering in a column wrap this function in transpose function
Dim arr(), i As Long
ReDim arr(count - 1) 'being 0 based one dimensional array

For i = LBound(arr) To UBound(arr)
    If i = LBound(arr) Then
        arr(i) = IIf(Day(myDate) <= 15, DateSerial(Year(myDate), _
        Month(myDate), 15), WorksheetFunction.EoMonth(myDate, 0))
    Else
        arr(i) = IIf(Day(arr(i - 1)) = 15, _
        WorksheetFunction.EoMonth(arr(i - 1) + 1, 0), arr(i - 1) + 15)
    End If
Next i
HalfMonthDateSeries = arr
End Function

过程中

Sub Print_HalfMonthDateSeries()
Dim arr, i As Long
arr = HalfMonthDateSeries(Date, 5)
' or arr = HalfMonthDateSeries(#7/13/2021#, 5)
For i = LBound(arr) To UBound(arr)
    Debug.Print CDate(arr(i))
    ' or Cells(i + 2, 1) = CDate(arr(i))
Next i
End Sub