Consulting

Page 1 of 2 1 2 LastLast
Results 1 to 20 of 22

Thread: Update Calendar Fills by Revolving Sequence Using VBA

  1. #1
    VBAX Regular
    Joined
    Sep 2019
    Posts
    57
    Location

    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
    Attached Files Attached Files
    Last edited by Marsau; 09-14-2019 at 12:56 PM.

  2. #2
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,956
    Location
    Here is the delete macro that you can Assign. Test on backup copy as usual.
    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

  3. #3
    VBAX Regular
    Joined
    Sep 2019
    Posts
    57
    Location
    Thank you Kenneth
    Will Undo work once macro runs for this delete?

  4. #4
    VBAX Regular
    Joined
    Sep 2019
    Posts
    57
    Location
    Delete macro tested and is working

  5. #5
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,956
    Location
    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.

  6. #6
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,956
    Location
    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

  7. #7
    VBAX Regular
    Joined
    Sep 2019
    Posts
    57
    Location
    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?

  8. #8
    VBAX Regular
    Joined
    Sep 2019
    Posts
    57
    Location
    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.

  9. #9
    VBAX Regular
    Joined
    Sep 2019
    Posts
    57
    Location
    MSG Box.jpg
    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

  10. #10
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,956
    Location
    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.
    Attached Files Attached Files

  11. #11
    VBAX Regular
    Joined
    Sep 2019
    Posts
    57
    Location
    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.
    Last edited by Marsau; 09-15-2019 at 09:07 AM.

  12. #12
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,956
    Location
    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.

    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.
    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
    Attached Files Attached Files
    Last edited by Kenneth Hobs; 09-15-2019 at 11:29 AM.

  13. #13
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,956
    Location
    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.
        With Worksheets("Year Planner")
        'With ActiveSheet

  14. #14
    VBAX Regular
    Joined
    Sep 2019
    Posts
    57
    Location
    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?
    Last edited by Marsau; 09-15-2019 at 12:16 PM.

  15. #15
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,956
    Location
    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.

    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
    Attached Files Attached Files

  16. #16
    VBAX Regular
    Joined
    Sep 2019
    Posts
    57
    Location
    That code is working beautifully


  17. #17
    VBAX Regular
    Joined
    Sep 2019
    Posts
    57
    Location
    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
    Attached Files Attached Files

  18. #18
    VBAX Regular
    Joined
    Sep 2019
    Posts
    57
    Location
    Any Excel Genie ready to improve on current file added?

  19. #19
    VBAX Regular
    Joined
    Sep 2019
    Posts
    57
    Location
    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.
    Attached Files Attached Files

  20. #20
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,956
    Location
    Please start a new thread for #19.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •