Update Calendar Fills by Revolving Sequence Using VBA

Hi there all

I have a spread sheet that generates a calendar and I have a 28 day cycle menu that i need to link to the callendar days. currently i read in manually in bold under the dates.
Can someone assist to enable me to in any year and any month to read in a specific menu number and the rest will be populated and outomatically populate any other chosen year or month there after until i clear to restart. the menu repeats after menu no 28 and start again at 1.

menu 1 always starts on a monday and so on...meaning certain menus falls under certain days........1,8,14,21= can only fall on mondays
I would like a warning buit in if the menu no's dont correspond to the right callendar days too.
would also like the clear menus button to clear all menus that have been read in

please help

Here is the delete macro that you can Assign. Test on backup copy as usual.

Code:

---

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  'Used for quick testing on copies of sheet1 as 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

---

Thank you Kenneth
Will Undo work once macro runs for this delete?

Delete macro tested and is working:thumb

Easy to test but no, it does not undo. You can use a MsgBox() to confirm. Once it works, there should be no issue. Especially, if the menus can be added back easily.

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:

Code:

---

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:

Code:

---

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

---

Thank you.

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.

Agreed that option two is the better choice. Any Body that can help?

Just a thought.........
If option 2 is used......
If i create a fill menus button
Can the macro used for option 2 first start with popup message to show year and january, as well as a question that asks what menu no would you like to start 1 january and year with and a block for the member to populate choice? Then the code polulates the rest.

Attachment 25064
Where the day of the 1st of that year can only produce these options:
Monday = 1,8,15,22
Tue =2,9,16,23
Wed = 3,10,17,24
Thursday = 4,11,18,25
Friday = 5,12,19,26
Sat = 6,13,20,27
Sun = 7,14,21,28



Dont know if this helps to get message accross

If you have that userform #9 and want to use it, you can post a file with it. I will code it to update.

The thing is, once a date is set, at some point, the cycle will be off in relation to menu 1 on a Monday in a month. You can see that in the example file when 24 is used as menu for Jan 1, 2019. It is fine until May, August, and October. The other months follow the sequence properly.

I guess you have to decide if the menu will be yearly or can span a year like a school year does.

I would think that once a person was on a 28 day cycle, if the sequence was consistent and unbroken from one month to another, it would not matter. Unbroken means if last day of month is menu 15, then the next day in the next month would be 16. Doing it that way, the menu numbers would refill based on that original date and start menu number no matter what future month and year was changed on 1st sheet.

If option (2) was used in this version of the file, picking 24 is the same until May. May 1 would be menu 3 in option (2) and continue from there. To keep that 1st Monday as a menu 1, made it jump from menu 2 on April 30 to menu 24 in May.

Thank you.

You can see that I am really new at this and have been writing these spreadsheets for work the long difficult way all the time.

You are once again totally right in saying that using the first of monday of every month wont work.

I theory once the menu is running it should for ever keep on looping from 1 to 28 year in and year out. Unbroken as you mentioned.

The only thing I would have liked is for the people to have an option as to when they will implement there menu by choosing a starting date. Also to be able to start over if for instance there is a winter and summer menu.

What ever you suggest I will take at this point knowing it will probably be the best anyway.

That user form no 9 was just a demmo I drafted in powerpoint to get message accross.

Change the added sheet to start a menu on a certain date. Everything updates if either of the two yellow cells change value.

Those two cells are unprotected. At some point, you will probably want to password protect the vbaproject and the sheets. If the sheet's protect option UserInterfaceOnly:=True then the macro code can make sheet changes. That can be added to all sheets at ThisWorkbook's Open event.

As you can see on the new sheet, if the menu number is entered at some other date, overwriting the formula, one can change the menu cycle from that point on. The danger is that the user would overwrite a formula and then want to go back. One can simply fill back the formula.

That above can be coded to trigger the updates to the other 2 sheets as the yellow cells do now. As is now, it can also update those 2 sheets if the calendar year, month, or start weekday is changed.

Code:

---

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")
              Set r = MonthMenuRange(c) 'month range of menu cells
              ' Ordered array of menu numbers
              a = oA28(c.Value, r.Count)
              Debug.Print
              ' Fill calendar with ordered menu numbers
              i = 0
              For Each cc In r
                  i = i + 1
                  cc = a(i, 1)
            Next cc
        Next c
    End With   
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub


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


Function oA28(d, aSize As Integer)
      Dim a, ws3 As Worksheet, r As Range
      Set ws3 = Worksheets("Start Menu")
      Set r = ws3.Range("B2", ws3.Cells(Rows.Count, "B").End(xlUp))
      Set r = r.Find(d, ws3.Cells(Rows.Count, "B").End(xlUp), xlValues, searchdirection:=xlNext)
      Set r = r.Resize(aSize).Offset(, -1)
      oA28 = r
End Function

---

New sheet's code to trigger updates if yellow cells are changed.

Code:

---

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

---

Please respond in the thread and not in a PM. Others might have the same issues.

Delete the ActiveSheet line or comment it out in the Modular code and uncomment the Year Planner line. I fixed it in post #12.

Code:

---

With Worksheets("Year Planner")
  ' With ActiveSheet

---

Maybe I am just to tired or brain to slow.

It is done that way and i still get error.


My computer language and dates set to English South Africa. Can that influence vba code?

I made some changes to make sure that the new sheet calculates after the change. The last version had some tests for the change cycle which left the dates as 0. It is a bit slower that way but still ok. If not, I can tweak it for the other sheets to not update until after the run.

I also added a routine, at the end, to make restoring function after an error easier. Hopefully, this is just needed for the development version.

Code:

---

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")
              Set r = MonthMenuRange(c) 'month range of menu cells
              ' Ordered array of menu numbers
              a = oA28(c.Value, r.Count)
              Debug.Print
              ' Fill calendar with ordered menu numbers
              i = 0
              For Each cc In r
                  i = i + 1
                  cc = a(i, 1)
              Next cc
          Next c
    End With   
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub


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


Function oA28(d As Date, aSize As Integer)
    Dim a, ws3 As Worksheet, r As Range, f As Range
    Set ws3 = Worksheets("Start Menu")
    Set r = ws3.Range("B2", ws3.Cells(Rows.Count, "B").End(xlUp))
    Set f = r.Find(d, ws3.Cells(Rows.Count, "B").End(xlUp), xlValues, , xlNext)
    Set r = f.Resize(aSize).Offset(, -1)
    oA28 = r
End Function




'--------------------------- Tests and Routines Not Used -----------------
'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


Sub Test_oA281()
    Dim a
    a = oA281(7, 31)
    Debug.Print Join(a, vbCrLf)
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 oA281(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
    oA281 = a
End Function


Sub Test_oA28()
    Dim a
    'a = oA28(DateSerial(2019, 1, 1), 31)
    a = oA28(DateSerial(2019, 2, 1), 28)
    'MsgBox Join(WorksheetFunction.Transpose(a), vbCrLf)
End Sub




Sub RestoreAfterError()
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

---

That code is working beautifully

:thumb

With all the help received I have tinkered around on project.

Here is sample file for perusal before I continue to next phase.

All assistance to clean and speed up project will be appreciated.

Thank You

Any Excel Genie ready to improve on current file added?

Can any body help with the following problem in vba code.
i have one file (28 Day Planned) with a 28 menu shopping list.
A second file (monthly Shopping).
I would like monthly shopping list to look up the menu no in first file and populate the choice automatically.

Please start a new thread for #19.

thank you will do

Update Shopping list Fills by looking up on another workbook Using VBA