如何获取当月的星期一（完整日期）？

Question

我正在尝试获取当月星期一的所有日期。例如，在 2021 年 5 月的当前月份，我们将有：3/05/2021、10/05/2021、17/05/2021、24/05/2021、31/05/2021。

在调查中，我发现了一个旧问题的答案，这有助于 Calculate the number of weeks in a month，但是这显示 6 作为答案。哪个是正确的（请参阅共享日历）。但是我希望只计算该月的星期一。

我还有一个补充代码，可以告诉我当月的星期一数：

Sub NumMondays()

    Dim i As Integer
    Dim num_mondays As Integer
    Dim test_date As Date
    Dim orig_month As Integer
    
    month_name = Format(Date, "mmmm")
    year_name = Format(Date, "yyyy")
    ' Get the first day of the month.
    test_date = CDate(month_name & " 1, " & year_name)
    
    ' Count the Mondays.
    orig_month = Month(test_date)
    Do
        num_mondays = num_mondays + 1
        test_date = DateAdd("ww", 1, test_date)
    Loop While (Month(test_date) = orig_month)
    
    Debug.Print test_date
    Debug.Print orig_month
    Debug.Print num_mondays
    
End Sub

这样的代码打印 5 表示星期一的数量，但是我无法将其转换为此类星期一的实际日期。有什么建议吗？

提前非常感谢

Answer 1

请尝试下一个代码：

Sub NumMondays()
 Dim i As Long, month_name, year_name, num_mondays As Integer
 Dim test_date As Date, orig_month As Integer, arrMondays, k As Long

 month_name = Format(Date, "mmmm")
 year_name = Format(Date, "yyyy")
 ' Get the first day of the month.
 test_date = CDate(month_name & " 1, " & year_name)

 orig_month = month(test_date)
 ReDim arrMondays(4)
 'extract and count Mondays:
 Do
    If Weekday(test_date, vbMonday) = 1 Then
        arrMondays(k) = test_date: k = k + 1: num_mondays = num_mondays + 1
    End If
    test_date = test_date + 1
 Loop While (month(test_date) = orig_month)
 ReDim Preserve arrMondays(k - 1)

 Debug.Print "Current month no = " & orig_month
 Debug.Print "No of Mondays = " & num_mondays
 Debug.Print Join(arrMondays, ", ")
End Sub

Answer 2

不同的方法。有一个众所周知的 Excel 公式提供给定周数和年份的星期一 (=DATE(A2, 1, -2) - WEEKDAY(DATE(A2, 1, 3)) + B2 * 7) [A2 是年份, B2 是周数]。在这种情况下，我会在一个月内循环所有周，并在每周使用该公式。

Sub CaseOfTheMondays()
    Dim inDate As Date, sDate As Date, eDate As Date, sYear As Date, mDate As Date
    Dim cMonth As Integer, i As Integer, x As Integer
    inDate = InputBox("Enter a valid date")
    If IsDate(inDate) Then
        ThisWorkbook.Worksheets(1).Columns("A").ClearContents
        sDate = DateAdd("d", -(Format(inDate, "d") - 1), inDate)
        eDate = DateAdd("m", 1, inDate) - (Format(inDate, "d") + 1)
        sYear = DateAdd("m", -(Format(inDate, "m") - 1), DateAdd("d", -(Format(inDate, "d") - 1), inDate))
        cMonth = Format(inDate, "m")
        sWeek = WorksheetFunction.WeekNum(sDate, vbMonday)
        eWeek = WorksheetFunction.WeekNum(eDate, vbMonday)
        x = 1
        For i = sWeek To eWeek
            mDate = DateAdd("d", -3, sYear) - Weekday(DateAdd("d", 2, sYear)) + (i * 7)
            If Format(mDate, "m") = cMonth Then
                ThisWorkbook.Worksheets(1).Cells(x, 1).Value = mDate
                x = x + 1
            End If
        Next i
    Else
        MsgBox "invalid date"
    End If
End Sub

Answer 3

暴力破解

Sub tester()
    Dim dt
    For Each dt In GetDayDates(2021, 5, "Mon")
        Debug.Print dt
    Next dt
End Sub

Function GetDayDates(yr As Long, mon As Long, d As String)
    Dim dt As Date, col As New Collection
    dt = DateSerial(yr, mon, 1)
    Do While Month(dt) = mon
        If Format(dt, "ddd") = d Then col.Add dt
        dt = dt + 1
    Loop
    Set GetDayDates = col
End Function

Answer 4

功能性解决方案

一个好的方法是使用一个函数，该函数将返回指定月份的日期集合。

这与提供的其他方法类似 - 但是，这增加了一点性能，更重要的是 intellisense 在一周中的某一天。

Public Function GetMonthDays(dayToGet As VbDayOfWeek _
, monthToGetFrom As Long _
, yearToGetFrom As Long) As Collection

    Set GetMonthDays = New Collection
    
    ' First Starting date, and will be used
    ' for incrementing to next date/next day.
    Dim nextDate    As Date
    nextDate = DateSerial(yearToGetFrom, monthToGetFrom, 1)
    
    ' Loop until month changes to next month.
    Do While month(nextDate) = monthToGetFrom
        ' If weekday matches, then add and
        ' increment to next week (7 days)
        If Weekday(nextDate) = dayToGet Then
            GetMonthDays.Add nextDate
            nextDate = nextDate + 7
            
            ' Day did not match, therefore increment
            ' 1 day until it does match.
        Else
            nextDate = nextDate + 1
        End If
    Loop
End Function

示例

这是一个如何使用它的基本示例。

Sub testGetMonthDays()
    Dim mondayDate As Variant
    For Each mondayDate In GetMonthDays(vbMonday, month(Date), year(Date))
        Debug.Print mondayDate
    Next
End Sub

5/3/2021 
5/10/2021 
5/17/2021 
5/24/2021 
5/31/2021