Divide month in week numbers with VBA

Question

I am aware that this question has been asked in many different forms, but I would like to show my case as I have not found the perfect solution for it.

So, what I need to do is divide every month in 4 or 5 weeks, and type it into the corresponding cells.

Example :

I have tried this sample code written by User : danieltakeshi in this thread :

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

But it has a flaw in it, for example if you type a date from October 2021 the result outputs 6 weeks which is impossible :

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

Please help me find a solution, or tell me how I can adapt it to my current situation.

Cordially,

Answer 1

This routine checks for the first and last workingday (monday to friday) and then gives the calendar weeks for that date range

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

Answer 2

First, some months have dates in six weeks.

Next, VBA natively can't return the correct ISO 8601 weeknumbers:

How to get correct week number in Access

Finally, week numbers don't care about workdays or weekends. If you wish to exclude weeks that don't include specific weekdays, filter on the dates of these.