excel - 用 VBA 将月份除以周数

Question

我知道这个问题已经以许多不同的形式提出，但我想展示我的案例，因为我还没有找到完美的解决方案。

所以，我需要做的是将每个月划分为 4 或 5 周，并将其输入到相应的单元格中。

例子 ：

我在这个线程中尝试了用户编写的示例代码：danieltakeshi：

https://stackoverflow.com/a/47393516/11969596

但它有一个缺陷，例如，如果您输入 2021 年 10 月的日期，结果会输出 6 周，这是不可能的：

Sub WeeksInMonth()
Dim MonthYear As String, txt As String
Dim InputDate As Date, MonthYearDay As Date
Dim i As Long, intDaysInMonth As Long, j As Long
Dim MyArray As Variant
Dim arr As New Collection, a
ReDim MyArray(0 To 31)
j = 0
InputDate = ("1 / 10 / 2021") ' Date from October
MonthYear = Month(InputDate) & "/" & Year(InputDate)
intDaysInMonth = Day(DateSerial(Year(MonthYear), Month(MonthYear) + 1, 0))
For i = 1 To intDaysInMonth
    MonthYearDay = DateSerial(Year(InputDate), Month(InputDate), i)
    MyArray(j) = Application.WorksheetFunction.WeekNum(MonthYearDay)
    j = j + 1
Next i

ReDim Preserve MyArray(0 To j - 1)
On Error Resume Next
For Each a In MyArray
    arr.Add a, CStr(a)
Next

For i = 1 To arr.Count
    Debug.Print arr(i)
Next
End Sub

请帮助我找到解决方案，或告诉我如何使其适应我目前的情况。

亲切地，

标签： excelvba

Answer 1

此例程检查第一个和最后一个工作日（周一至周五），然后给出该日期范围的日历周

Option Explicit

Public Sub test_getWeeknumbersForMonth()

Dim arr As Variant
arr = getWeekNumbersForMonth("1.10.2021")
Debug.Print "1.10.2021: ", Join(arr, " - ")

arr = getWeekNumbersForMonth("1.1.2022")
Debug.Print "1.1.2022: ", Join(arr, " - ")


End Sub


Public Function getWeekNumbersForMonth(inputDate As Date) As Variant

Dim datStart As Date
datStart = getFirstWorkingDayOfMonth(inputDate)

Dim datEnd As Date
datEnd = getLastWorkingDayOfMonth(inputDate)

Dim arrWeekNumbers As Variant
ReDim arrWeekNumbers(1 To 6)    'max 6 weeks can be returned

Dim i As Long: i = 1

Dim dat As Date
dat = datStart

While dat <= datEnd
    arrWeekNumbers(i) = getCalendarWeek(dat)
    i = i + 1
    dat = DateAdd("ww", 1, dat)
Wend
    
ReDim Preserve arrWeekNumbers(i - 1)
getWeekNumbersForMonth = arrWeekNumbers

End Function



Private Function getFirstWorkingDayOfMonth(inputDate As Date) As Date
Dim datToCheck As Date: datToCheck = DateSerial(Year(inputDate), Month(inputDate), 1) - 1

Dim isWorkingday As Boolean
Do
    datToCheck = datToCheck + 1
    isWorkingday = Weekday(datToCheck, vbMonday) <= 5
Loop Until isWorkingday = True

getFirstWorkingDayOfMonth = datToCheck

End Function



Private Function getLastWorkingDayOfMonth(inputDate As Date) As Date
Dim datToCheck As Date: datToCheck = DateSerial(Year(inputDate), Month(inputDate) + 1, 1)

Dim isWorkingday As Boolean
Do
    datToCheck = datToCheck - 1
    isWorkingday = Weekday(datToCheck, vbMonday) <= 5
Loop Until isWorkingday = True

getLastWorkingDayOfMonth = datToCheck

End Function



Private Function getCalendarWeek(inputDate As Date) As Long

'european iso week - CW 1 = week with first thursday
getCalendarWeek = Application.WorksheetFunction.IsoWeekNum(inputDate)

'use weeknum-function -adjust second parameter to your needs
'https://support.microsoft.com/en-us/office/weeknum-function-e5c43a03-b4ab-426c-b411-b18c13c75340
'getCalendarWeek = Application.WorksheetFunction.WeekNum(inputDate, 2)
End Function