Issue making Calendar

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