Divide month in week numbers with VBA-CodePudding

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 :

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

Cordially,

CodePudding user response：

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

CodePudding user response：

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.