Issue making Calendar - excel

Question

I got problem with calendar in VBA. Wants to create a calendar that will show/paint the range of week numbers from 2022 depending on the date entered in columns A22 and B22. The problem occurs when the week numbers repeat between months.
Tydzien = Week
Sty = January
Lut = February
Option Explicit
Sub Kolorowaniedaty()
Dim rok As Integer
rok = Left(Cells(22, 2), 4)
Dim miesiacpocz As Integer
miesiacpocz = Mid(Cells(22, 2), 7, 1)
Dim miesiackon As Integer
miesiackon = Mid(Cells(22, 3), 7, 1)
Dim Datapocz As Integer
Datapocz = Application.WorksheetFunction.WeekNum(Cells(22, 2), 2)
Dim Datakon As Integer
Datakon = Application.WorksheetFunction.WeekNum(Cells(22, 3), 2)
Dim Rokzdaty As String
Rokzdaty = CStr(Mid(Cells(22, 2), 3, 2))
Dim Rok2022 As Byte
Rok2022 = 22
Dim kolumna As Byte
For kolumna = 1 To 20
If Rokzdaty = Rok2022 And miesiacpocz = miesiackon Then
Range(Cells(22, Datapocz + 4), Cells(22, Datakon + 4)).Interior.Color = vbYellow
Else: Range(Cells(22, Datapocz + 4), Cells(22, Datakon + 5)).Interior.Color = vbYellow
End If
Next kolumna
End Sub
I cant upload image of Makro and Calendar from excel cuz i dont have enought points of reputations. If someone can help from private chat i will be really really thankful. Its must have from to my work.
[![enter image description here][3]][3]
Its Its suppose to mark 11 weeks but its show only 10 weeks. Any advice?
[3]: https://i.stack.imgur.com/X8kwQ.png

Answer 1

Iterate over each day in the date range and increment the column number each monday or change of month. Store the column numbers in an array and use it as a lookup to determine the column number for a given date. Run this is a new clean workbook.
update - complete rewrite
Option Explicit
Const START_COL = 4
Const START_ROW = 22
Const MAX_YEARS = 4
Const START_YEAR = 2022
Sub CalendarDemo()
Dim ws As Worksheet
Dim dt As Date, dtDay1 As Date
Dim wkno As Long, dayno As Long
Dim colno As Long, i As Long, c As Long, r As Long
Dim arCol, arDate
ReDim arCol(1 To 2, 1 To MAX_YEARS * 12 * 7)
ReDim arDate(1 To MAX_YEARS * 366, 1 To 5) ' wkno, month no, column, date, dow
' start Jan 1
dtDay1 = DateSerial(START_YEAR, 1, 1)
colno = 1
wkno = 1
i = 1
' iterate through days built look up array
dt = dtDay1
Do While Year(dt) < START_YEAR + MAX_YEARS
arDate(i, 2) = Month(dt)
arDate(i, 5) = Weekday(dt, vbMonday)
If i > 1 Then
' change of week or month
If arDate(i, 5) = 1 Then
wkno = wkno + 1
If (wkno > 52) And (Month(dt) = 1) Then wkno = 1
colno = colno + 1
ElseIf arDate(i, 2) <> arDate(i - 1, 2) Then
colno = colno + 1
End If
End If
' reset wkno to 1 on jan 1st
If wkno >= 52 And arDate(i, 2) = 1 Then wkno = 1
arDate(i, 1) = wkno
arDate(i, 3) = colno
arDate(i, 4) = dt
' fill arCol
arCol(1, colno) = Format(dt, "mmm yyyy")
arCol(2, colno) = wkno
dt = dt + 1
i = i + 1
Loop
' paint cells
Dim lastrow As Long, dtStart As Date, dtEnd As Date
Dim colStart As Long, colEnd As Long, n As Long, m As Long
Set ws = Sheets(1)
Call testdata(ws)
With ws
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
For r = START_ROW To lastrow
' check dates are valid
dtStart = .Cells(r, "B")
dtEnd = .Cells(r, "C")
If dtEnd < dtStart Then
MsgBox "End Date before Start Date on row " & r, vbCritical
Exit Sub
ElseIf dtStart < dtDay1 Then
MsgBox "Start Date before 1 Jan " & START_YEAR & " on row " & r, vbCritical
Exit Sub
End If
' calc day number relative to day1
m = DateDiff("d", dtDay1, dtStart, dtDay1) + 1
n = DateDiff("d", dtDay1, dtEnd, dtDay1) + 1
If n > UBound(arDate) Or m > UBound(arDate) Then
MsgBox "Increase MAX_YEARS for row " & r, vbCritical
Exit Sub
End If
' lookup col number
colStart = arDate(m, 3) + START_COL
colEnd = arDate(n, 3) + START_COL
' merge and color
With .Cells(r, colStart)
With .Resize(1, colEnd - colStart + 1)
.Interior.Color = vbYellow
.Borders.LineStyle = xlContinuous
.Merge
End With
.Value = Space(5) & Format(dtStart, "dd mmm") & " - " & Format(dtEnd, "dd mmm yyyy")
End With
Next
End With
' add headers
Call FormatSheet(ws, arCol, arDate, colno)
MsgBox "Generated " & colno & " Columns", vbInformation
End Sub
Sub FormatSheet(ws As Worksheet, arCol, arDate, colno As Long)
Dim c As Long, i As Long, n As Long, dt As Date
' format sheet header rows
With Sheet1
.Rows("10:21").Clear
.Cells.MergeCells = False
With .Range("E20").Resize(2, colno)
.NumberFormat = "#"
.HorizontalAlignment = xlCenter
.Value2 = arCol
End With
' merge months
i = 0
For c = 5 To colno + 4
If .Cells(20, c + 1) = .Cells(20, c) Then
i = i + 1
Else
With .Cells(20, c - i)
Application.DisplayAlerts = False
.Resize(1, i + 1).Merge
Application.DisplayAlerts = True
.Resize(2, 1).Borders(xlLeft).LineStyle = xlContinuous
End With
i = 0
End If
Next
End With
' calendar to check array
For i = 1 To UBound(arDate)
dt = arDate(i, 4) ' date
n = arDate(i, 5) ' weekday
If dt > 0 Then
n = Weekday(dt, vbMonday)
ws.Cells(10 + n, arDate(i, 3) + START_COL) = Day(dt)
End If
' mon,tue,wed
If i < 8 Then
ws.Cells(10 + n, START_COL) = WeekdayName(n)
End If
Next
End Sub
Sub testdata(ws)
With ws
.Cells(22, 2) = "2022-01-01": .Cells(22, 3) = "2022-03-08"
.Cells(23, 2) = "2022-02-01": .Cells(23, 3) = "2022-02-28"
.Cells(24, 2) = "2022-03-01": .Cells(24, 3) = "2022-03-31"
.Cells(25, 2) = "2022-03-15": .Cells(25, 3) = "2022-05-15"
.Cells(26, 2) = "2022-03-15": .Cells(26, 3) = "2024-03-20"
End With
End Sub