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
Reply With Quote