Update Calendar Fills by Revolving Sequence Using VBA

[Kenneth Hobs]

As usual, test on a backup copy.

While I did code it to set menu 1 for 1st Monday in each month, there is a problem in going from one month to next for some months.

Other ways you might want to consider:
1. Change all month's menus when 1st menu of first month changes. The 28 day cycle would start with that number and fill to all months.
a. This could be a problem when month, day of week, year is changed on 1st sheet.

2. Set a starting menu number for some date in a range.
a. Set a starting menu number for that day.
b. Macro completes the fill for both columns to a date like 10 or 20 years.
c. Write new code to reset menus based on this range of dates and menus.
d. Changes to 1st sheet for month, day of week, and year would then fill properly.

For 1st Monday each month as menu 1:

Sub FillMenus()    
    Dim rC As Range, rSLd As Range, aSLd
    Dim i As Integer, j As Integer, d As Double, s As String
    Dim ws As Worksheet, ws2 As Worksheet
    Dim f As Range, c As Range, v, aa(1 To 31)    
    Set ws = Worksheets("Year Planner")
    Set rC = ws.[A9:W65]
    Set ws2 = Worksheets("SHOPPING LIST")    
    With ws2
          Set rSLd = .[D6:AH6]
          aSLd = WorksheetFunction.Transpose(rSLd)        
          ' Array a with Dates for Shopping List day numbers.
          For i = 1 To 31
               s = .[C2]     'needed due to merge cell issue
               d = Month(DateValue("01-" & s & "-1900"))
               ' d = DateSerial(.[E2], d, aSLd(i, 1))
               ' If not a full year, find year and set d value
              For Each c In ws.Range("A7, I7,Q7,A22,I22,Q22,A37, I37, Q37, A52, I52, Q52")
                  If Month(c.Value) = d Then
                      d = DateSerial(Year(c.Value), d, aSLd(i, 1))
                      Exit For
                  End If
            Next c
            aSLd(i, 1) = d
        Next i
        ' Find the month/year in ws, use cell interation due to merged cells.
        For Each c In ws.Range("A7, I7,Q7,A22,I22,Q22,A37, I37, Q37, A52, I52, Q52")
            If c = aSLd(1, 1) Then
                Set f = c
                Exit For
            End If
        Next c        
        On Error Resume Next
        Set f = f.Offset(3).Resize(11, 7) 'Month block on ws
        For i = 1 To f.Rows.Count Step 2 'menu rows
              Set c = f.Rows(i)
              For j = 1 To 7
                   v = Day(c.Cells(j).Offset(-1)) 'day number on ws
                   If v >= 1 And v <= 31 Then
                       d = CInt(c.Cells(j))
                       If d <> 0 Then aa(v) = d
                  End If
            Next j
        Next i        
        rSLd.Offset(2) = aa
        'MsgBox Join(aa, vbCrLf)
    End With
End Sub


Sub Del12Months()
    Dim i As Integer, j As Integer, r As Range, c As Range    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    ' With Worksheets("Year Planner")
    With ActiveSheet
        For i = 7 To 52 Step 15
            '1st row of 3 months menus
            Set r = Range(.Cells(i, "A"), .Cells(i, "W")).Offset(3)
            For j = 0 To 10 Step 2
                Set c = r.Offset(j)
                c.ClearContents
            Next j
        Next i
    End With    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub


Sub Fill12Months()
    Dim i As Integer, j As Integer, r As Range, c As Range
    Dim fm As Integer, k As Integer, a, cc As Range    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    With Worksheets("Year Planner")
    'With ActiveSheet
        For Each c In Range("A7,I7,Q7,A22,I22,Q22,A37,I37,Q37,A52,I52,Q52")
            fm = Day(FirstMonday(c.Value))
            'Ordered array of menu numbers
            a = oA28(fm, NoDaysInMonth(c.Value))
            Set r = MonthMenuRange(c) 'month range of menu cells
            'Fill calendar with ordered menu numbers
            i = 0
            For Each cc In r
                i = i + 1
                cc = a(i)
            Next cc
        Next c
    End With    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub


'Order of 28 day menu items with i as first Monday of the month day number.
'aSize is number of days in the month to fill the array.

Function oA28(i As Integer, aSize As Integer)
    Dim a, k As Integer, j As Integer
    ReDim a(1 To aSize)
    k = 30 - i
    For j = 1 To aSize
        If k > 28 Then k = 1
        a(j) = k
        k = k + 1
    Next j
    oA28 = a
End Function


Function MonthMenuRange(rD As Range) As Range
    Dim c As Range, r As Range, d As Date, v    
    For Each c In AMonthMenuRange(rD).Cells
        If Not IsDate(c.Offset(-1)) Then GoTo NextC
        If r Is Nothing Then
            Set r = c
            Else
            Set r = Union(r, c)
        End If
NextC:
    Next c
    Set MonthMenuRange = r
End Function


Function AMonthMenuRange(rD As Range) As Range
    Dim i As Integer, r As Range, c As Range    
    Set r = rD.Offset(3).Resize(, 7)
    For i = 0 To 10 Step 2
        Set c = rD.Offset(3 + i).Resize(, 7)
        Set r = Union(r, c)
    Next i
    Set AMonthMenuRange = r
End Function


'https://stackoverflow.com/questions/45564927/first-monday-of-current-month-in-vba

Function FirstMonday(myDate As Date) As Date
      Dim d As Date, w As Long
      d = DateSerial(Year(myDate), Month(myDate), 1)
      w = Weekday(d, vbMonday)
      FirstMonday = d + IIf(w <> 1, 8 - w, 0)
End Function


Function NoDaysInMonth(d As Date) As Integer
      NoDaysInMonth = Day(DateAdd("m", 1, d - Day(d) + 1) - 1)
End Function

RIght click 1st sheet's tab, View Code, and paste:

Private Sub Worksheet_Change(ByVal Target As Range)    
     Dim r As Range    
     Set r = Range("A2,E2,I2")
     If r Is Nothing Then Exit Sub    
     Del12Months
     Fill12Months
     FillMenus
End Sub