Code for a Calendar W/Notes

[mperrah]

I have a userform (CalendarOpts) that gets a 3 column listbox (lbBills)
populated from a range on my main sheet B2 to D & lastrow

On the userform I allow the user to add, remove and modify the listbox items.

Then we can generate a calendar that gets populated with the listbox values.

My problem is even if the values have been modified, the calendar seems to get the original initialized values, not the modified list.
Is there a way to register in memory (or what ever is necessary) the new values from the userform

This is the initialize code:

Private Sub UserForm_Initialize()
    Dim lbtarget As MSForms.ListBox
    Dim rngSource As Range
    Dim lrB As Integer
    Dim wsB As Worksheet
    
    Set wsB = Sheets("Bills")
    lrB = wsB.Cells(Rows.Count, 2).End(xlUp).Row
    Set rngSource = wsB.Range("B2:D" & lrB)
    
    Me.lblMonth.Caption = wsB.Range("cMonth").Value
    Me.sbMonth.Value = wsB.Range("cMonth").Value
    
    Me.lblYear.Caption = wsB.Range("cYear").Value
    Me.sbYear.Value = wsB.Range("cYear").Value
    
    Set lbtarget = Me.lbBills
    With lbtarget
        .ColumnCount = 3
        .ColumnWidths = "90;60;20"
        .List = rngSource.Cells.Value
    End With
    
End Sub

This is the makecalendar code:

Sub makeCalendar()
Dim t, lrV, x As Long
Dim StartDay, DayofWeek, CurYear, CurMonth, FinalDay As Date
Dim wsB, ws As Worksheet
Dim MyInput As String
Dim dNum As Range

Set wsB = Sheets("Bills")
    
    With wsB
        If IsUserFormLoaded(CalendarOpts.Name) = True Then
            MyInput = CalendarOpts.sbMonth.Value & "-" & CalendarOpts.sbYear.Value
        Else
            MyInput = .Range("cMonth").Value & "-" & .Range("cYear").Value
        End If
        
        If MyInput = "" Then Exit Sub
        
        For Each ws In ThisWorkbook.Worksheets
            If ws.Name = MyInput Then
                ws.Activate
                MsgBox ("The Calendar Month you are trying to create already exists." & vbCrLf & " The Options menu will close now.")
                End
            End If
        Next ws
        
    lrV = .Cells(Rows.Count, 2).End(xlUp).Row
    
    End With
    
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = MyInput

    ActiveSheet.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
            
    StartDay = DateValue(MyInput)
       
       If Day(StartDay) <> 1 Then
           StartDay = DateValue(Month(StartDay) & "/1/" & Year(StartDay))
       End If
       
       Range("a1").NumberFormat = "mmmm yyyy"
       
       With Range("a1:h1")
           .HorizontalAlignment = xlCenterAcrossSelection
           .VerticalAlignment = xlCenter
           .Font.Size = 18
           .Font.Bold = True
           .RowHeight = 35
       End With
       
       With Range("a2:h2")
           .ColumnWidth = 20
           .VerticalAlignment = xlCenter
           .HorizontalAlignment = xlCenter
           .VerticalAlignment = xlCenter
           .Orientation = xlHorizontal
           .Font.Size = 10
           .Font.Bold = True
           .RowHeight = 16
       End With
       
       Range("a2") = "Sunday"
       Range("b2") = "Monday"
       Range("c2") = "Tuesday"
       Range("d2") = "Wednesday"
       Range("e2") = "Thursday"
       Range("f2") = "Friday"
       Range("g2") = "Saturday"
       Range("h2") = "Week Subtotal"
       
       With Range("a3:h8")
           .HorizontalAlignment = xlRight
           .VerticalAlignment = xlTop
           .Font.Size = 12
           .Font.Bold = True
           .RowHeight = 14
           .ColumnWidth = 18
       End With
       
       Range("a1").Value = Application.Text(MyInput, "mmmm yyyy")
       
       DayofWeek = Weekday(StartDay)
       
       CurYear = Year(StartDay)
       CurMonth = Month(StartDay)
       
       FinalDay = DateSerial(CurYear, CurMonth + 1, 1)
       
       Select Case DayofWeek
           Case 1
               Range("a3").Value = 1
           Case 2
               Range("b3").Value = 1
           Case 3
               Range("c3").Value = 1
           Case 4
               Range("d3").Value = 1
           Case 5
               Range("e3").Value = 1
           Case 6
               Range("f3").Value = 1
           Case 7
               Range("g3").Value = 1
       End Select
       
       For Each dNum In Range("a3:g8")
          
           If dNum.Column = 1 And dNum.Row = 3 Then
       
           ElseIf dNum.Column <> 1 Then
               If dNum.Offset(0, -1).Value >= 1 Then
                   dNum.Value = dNum.Offset(0, -1).Value + 1
       
                   If dNum.Value > (FinalDay - StartDay) Then
                       dNum.Value = ""
                       Exit For
                   End If
               End If
       
           ElseIf dNum.Row > 3 And dNum.Column = 1 Then
               dNum.Value = dNum.Offset(-1, 6).Value + 1
       
               If dNum.Value > (FinalDay - StartDay) Then
                   dNum.Value = ""
                   Exit For
               End If
           End If
       Next

       For x = 0 To 5
            Range("A4").Offset(x * 2, 0).EntireRow.Insert
            With Range("A4:H4").Offset(x * 2, 0)
               .RowHeight = 85
               .HorizontalAlignment = xlCenter
               .VerticalAlignment = xlTop
               .WrapText = True
               .Font.Size = 10
               .Font.Bold = False
               .Locked = False
            End With
        
            With Range("A3").Offset(x * 2, 0).Resize(2, 8)
               .Borders(xlLeft).Weight = xlThin
               .Borders(xlLeft).ColorIndex = xlAutomatic
               .Borders(xlRight).Weight = xlThin
               .Borders(xlRight).ColorIndex = xlAutomatic
               .BorderAround Weight:=xlThin, ColorIndex:=xlAutomatic
            End With
       Next x
              
       ActiveWindow.DisplayGridlines = False
              
   End Sub

and this is the cod eto insert the bills:

Sub insertBills_UF()
Dim a, b, r, c, x, i, j As Long
Dim lbCnt As Integer
Dim ws, wsB, wsSel As Worksheet
Dim aBills()
Dim mySheet As String

        mySheet = CalendarOpts.lblMonth.Caption & "-" & CalendarOpts.lblYear.Caption
        If mySheet = "" Then
            MsgBox ("A calendar has not yet been made with the current Month Selection")
            Exit Sub
        End If
        
        For Each ws In ThisWorkbook.Worksheets
            If ws.Name = mySheet Then
                ws.Activate
               Set wsSel = ws
            End If
        Next ws
        
    If SheetExist(mySheet) Then
        
    Else
        MsgBox ("The Sheet Does NOT Exists")
        Exit Sub
    End If
        
lbCnt = CalendarOpts.lbBills.ListCount - 1

ReDim aBills(0 To lbCnt, 0 To 2)

    For a = 0 To lbCnt
        aBills(a, 0) = CalendarOpts.lbBills.List(a, 0)
        aBills(a, 1) = CalendarOpts.lbBills.List(a, 1)
        aBills(a, 2) = CalendarOpts.lbBills.List(a, 2)
    Next a

With wsSel
    For b = 0 To lbCnt
        For r = 3 To 38 Step 6
            For c = 1 To 7
                If .Cells(r, c).Value <> "" Then
                    If .Cells(r, c).Value = aBills(b, 2) Then
                        For x = 1 To 5
                            If .Cells(r + x, c).Value = "" Then
                                .Cells(r + x, c).Value = aBills(b, 0) & "-" & aBills(b, 1)
                                Exit For
                            End If
                        Next x
                    End If
                End If
            Next c
        Next r
    Next b
End With

End Sub

I have tried adding the modifications to the sheet then re-initialize from the sheet data,
this kind of works. but if there is a way to pull from the modified listbox would be more efficient,
eliminating going back and forth from the sheet and userform.

[p45cal]

A workbook please with a minimum of non-sensitive data, a userform etc. to prevent us having to try (wrongly) to re-create your workbook.
As an aside: "On the userform I allow the user to add, remove and modify the listbox items" -how?

[SamT]

I'm looking at that really deep FOR and IF loop in sub Sub insertBills_UF.

The Cells of a range, such as a 7x6 Calendar table, are numbered from top left to the right, then down. So Range("calendar").Cells(3) would be the Tuesday in the First week row. The Code

X =WeekDay("Aug-1-2015")

will return the number of the weekday of that date. In this particular case X = 7: The first Day of Aug was a Saturday, the 7th Cell of a Calendar Table

Since Day(Date) returns the day of the month of the given date, The code

Range("Calendar").Cells((X - 1) + Day(Date))

Will always return the correct Cell in the Calendar for that Date.

Today is Aug 19, so the calendar space for today is (7-1) + 19 or Cell # 25 of the Calendar. 7*3 = 21. 25 - 21 = 4. Today is the 4th day of the 4th week row. Wednesday.

If Sunday is not the first day of your weeks, be sure to see the helps for Day and Weekday to see how to compensate for a non default first day of week.

pr: The full name of the X variable above is "intFirstWeekdayOfMonth"

[mperrah]

BillCalendar_11.xlsm here you go p45Cal.
I have 3 textboxes, their values can be inserted in to the listbox.list with a command button "Add".
they can select an item in the listbox list and click command button "Modify", and the selected list item is overwritten with contents of text boxes.
they can select a list item and click command button "Remove", and the selected item is deleted from the listbox.
as they click a list item, its values get entered in the text boxes to make editing easier.
the command button "Clear" empties the textboxes to make a new entry.

SamT, I wasn't sure the best way to loop through all the calendar days then loop through 5 available slots for a bill to be inserted.
This, while clumsy, seems to work. I'll try to implement your solution.
I found the calendar generator on a forum so not sure all the ins and outs of its coding, but it seems to function for my purposes.

My current issue is I have set the calendar to hold a max of 5 bills per a given day.
I want to test if a bill being added in the listbox exceeds 5 bills on a given day,
the goal is select the day textbox and let them alter the day then finish the script.
Also n the Sheet, do the same thing. (I kind of have this part working)
if they add a new bill with a day that has 5 already, prompt the user to change it.

I have a sub that fires when they add a bill on the userform, but it doesnt seem to count correctly.

if I load the userform with 5 matching day bills and add one
it doesnt display the msgbox till I add a second matching bill instead of the first 1 causing the error message?!

here is the code that tests the 5 count

Sub test_5in1_UF()
' when adding new bill or making calendar from UF test for 5 bills per day
Dim i As Long, maxCount As Long, maxDup As Long
Dim myArray() As Long
 
ReDim myArray(1 To 31)
With CalendarOpts.lbBills
    For i = 0 To .ListCount - 1
        myArray(Val(.List(i, 2))) = myArray(Val(.List(i, 2))) + 1
        If maxCount < myArray(Val(.List(i, 2))) Then
            maxCount = myArray(Val(.List(i, 2)))
            maxDup = Val(.List(i, 2))
        End If
    Next i
End With
 
If maxCount > 5 Then
    MsgBox "There are " & maxCount & " bills for the " & maxDup & ". Only 5 bils will appear on the Calendar."
End If

End Sub

this is part that I tested adding the list back to the sheet where my test works then re-loading the userform...

Private Sub cbAddtoSheet_Click()
Dim i, j, lrB As Long
Dim arrItems()
Dim wsB As Worksheet

Application.ScreenUpdating = False

Set wsB = Sheets("Bills")
lrB = wsB.Cells(Rows.Count, 2).End(xlUp).Row

wsB.Range("B2:D" & lrB).ClearContents

ReDim arrItems(0 To lbBills.ColumnCount - 1)
    For j = 0 To lbBills.ListCount - 1
    
        For i = 0 To lbBills.ColumnCount - 1
            arrItems(i) = lbBills.Column(i, j)
        Next i

        wsB.Cells(j + 2, "B").Resize(, lbBills.ColumnCount).Value = arrItems
        
    Next j
    
    Call UserForm_Initialize
    
Application.ScreenUpdating = True
        
End Sub

thank you for your interest

[SamT]

Instead of use Calendar days with 5 cells each, use a single cell and the Cell Counting method above, but when adding Bills

If Cell.Value = "" Then
Cell.Value = "Bill String"
Else
Cell.Value  = Cell.Value & vbLF & "Bill String"
End If

there is no effective¹ limit on how many lines (bills) a cell can hold.

1: the limit is 32K characters including the vbLF character

[mperrah]

Thank you, I actually had thought of that. The only snag is I have a sum of the amounts due per week at the right of each week.
In each cell (so far up to 5) for each day I have the bill name then a dash then the amount due (name - amount)
I use a formula to pull just the numbers from the right of the bill in each of the 5 rows per day and sum them in the day number row.

calendar.jpg
I can figure how to do the calculations on the "Bills" sheet before making the calendar from the Sheet macro,
But I am at a loss how to due this in the userform macro.
I suppose if i do the calculations on the sheet then add them in a hidden column of the listbox...
But adding, removing or editing the listbox becomes an issue for these pre-made calculations...
and that is why I started this post.
I run into trouble with values in list box that have been altered after initialization.
If I am not limited to 5 entries per day, some of the testing could be eliminated.. nice
I'll have to ponder this. Thank you SamT

[p45cal]

I have a sub that fires when they add a bill on the userform, but it doesnt seem to count correctly.
…
if I load the userform with 5 matching day bills and add one
it doesnt display the msgbox till I add a second matching bill instead of the first 1 causing the error message?!

The code behind the Add button calls test_5in1_UF before adding to the .List (that's not fine) and regardless of the warning it adds it anyway (that's fine).

I haven't looked in depth at the rest of the code, but if you could try calling the test after addition to the .List instead of before and then update us on what's next going wrong.

By the way, while stepping through the code, you need to add some application.enableevents=true/false as there's a lot of unnecessary worksheet_change events being handled.

[SamT]

How about: Adding a hidden blank column between the calendar table and the weekly totals column so you can use Cell counting

Use a UDF in the weekly totals column

Public Function BillsTotal(WeeksCells As Range) As Double
Dim Result As Double
Dim Bills As Variant
Dim Bill As String
Dim Cel As Range
For Each Cel In WeeksCells
  Bills = Split(Cel.Value, vbLf)
  For i = LBound(Bills) To UBound(Bills)
    Bill = Bills(i)
    'Code Extract Number From Bill goes here
    Result = Result + NumberFromBill
  Next i
Next Cel
BillsTotal = Result
End Function

The Formula in I3 = "=BillsTotal(A3:G3)" (With a Blank Column G)

[SamT]

if you intend to use a UserForm to display and edit the calendar, then use a database table to record all information.

Each named Range(Calendar Cells 1 to 42) is 3 columns. You can use Range(Name).Columns(1 and 2) to reference Bills and Amounts and Range(Name).Cells(3 and 6) to reference Dates and Totals. You can also use Range(Name).Range("C1") to reference the date and ("C2") for the Total.

In this example, the first day of the month falls on a Monday. Note that even if you fill all CalendarCell Controls with the values in42 of these Named Ranges, the CalendarCell1 Controls and all other after the last day of the month, will be as empty as the cells in this table.

CalendarCell1			CalendarCell2			CalendarCell3
			Bill	Amount	1	Bill	Amount	2
			Bill	Amount	SubTotal	Bill	Amount	SubTotal
			Bill	Amount		Bill	Amount
			Bill	Amount		Bill	Amount
			Bill	Amount		Bill	Amount
			Bill	Amount		Bill	Amount

For Aug, 2015, Range("CalendarCell7").Cells(3).Value = 1

[mperrah]

My sub builds the calendar and adds the bills in sequence. I wasn't intending to adjust the calendar once it's made, per se. I was thinking if I add a bill it would be for the next month and as I build the calendar it fets added to the new one. I like the multiple lines in each cell and will attempt to incorporate that method.
I considered doing a scan in the bill list for the max number of bills on a day then using that as a variable to build the calendar. 1 row to what ever the max is)
using one cell could simplify the build process. I need to test the sub totaling and rebuild around that. Gonna have some homework. I love it. Thank you again samT

[SamT]

[mperrah]

P45cal,
i run the test before adding because if there are already 5 items with same date I want to prompt the user to change the date of what they are adding. Maybe there is a better way of going about this.
On the sheet I had a worksheet_change event that catches this. But I could not get it to work as intended on the user form. When I add or modify the listbox the count of matching dates seems to count incorrectly. Like it looks at the initial count in the list rather then the modified count.

[p45cal]

P45cal,
i run the test before adding because if there are already 5 items with same date I want to prompt the user to change the date of what they are adding. Maybe there is a better way of going about this.

But they don't get that opportunity, it goes on and adds them anyway.

But I could not get it to work as intended on the user form. When I add or modify the listbox the count of matching dates seems to count incorrectly. Like it looks at the initial count in the list rather then the modified count.

Correct! Because as I said, it counts the items in the list before adding anything (it also looks for >5, not >4 or exactly 5). I suggested in my previous post moving the test after adding to the list. Did it work any better - or didn't you test?

[mperrah]

p45cal - not tested yet. I have 1 pc at home with excel and my daughter usually confiscates it. I am installing it on a second one tonight, so I will update.. Thank you.

SamT - regarding the post #3
where does the 3 come from in 7*3 ?

Today is Aug 19, so the calendar space for today is (7-1) + 19 or Cell # 25 of the Calendar. 7*3 = 21. 25 - 21 = 4. Today is the 4th day of the 4th week row. Wednesday.

[mperrah]

p45cal - The sub seems to show the correct counting after using your suggestion to move the test after the add. Thank you.
Now what is a good way to prompt the user to change the 6 occurrence?
Ideally I'd like to select or highlight the 6 occurrence, or have a input box or userform with the date selected for changing.
Then after the user inputs a new date, it gets added or modified in the listbox. Thank you again.

[SamT]

SamT - regarding the post #3
where does the 3 come from in 7*3 ?

Today is Aug 19, so the calendar space for today is (7-1) + 19 or Cell # 25 of the Calendar. 7*3 = 21. 25 - 21 = 4. Today is the 4th day of the 4th week row. Wednesday.

Calendar Cell 25 is in the 4th Week Row. The last Calendar Cell of the 3rd Week Row is Cell 3x7

[mperrah]

SamT: not having success implementing your cell counting proposal.
Would you spell it out or save a workbook with it working please, i'd like to try it.

Also the Post #8 with the function for summing.
My code to strip the amounts from the name-amount format is quite lengthy,
not sure how the best way to incorporate the 2.

I plopped a formula on the sheet that does the calculating.
Maybe there is a way to accomplish this in vba, or as part of a function?

Sub sumWeekly_WS()
Dim r, x As Long
Dim ws, wsB, wsSel As Worksheet
Dim mySheet As String

Set wsB = Sheets("Bills")

        mySheet = wsB.Range("cMonth") & "-" & wsB.Range("cYear")
        If mySheet = "" Then
            MsgBox ("A calendar has not yet been made with the current Month Selection")
            Exit Sub
        End If
        
        For Each ws In ThisWorkbook.Worksheets
            If ws.Name = mySheet Then
                ws.Activate
               Set wsSel = ws
            End If
        Next ws

    If SheetExist(mySheet) Then
        
    Else
        MsgBox ("The Sheet Does NOT Exists")
        Exit Sub
    End If

    With wsSel
        .Cells(2, 8).Value = "Week Subtotal"
        For r = 3 To 33 Step 6
        .Cells(r, 8).FormulaR1C1 = "=Sum(R[1]C:R[5]C)"
            For x = 1 To 5
                .Cells(r + x, 8).FormulaR1C1 = "=SUM(IFERROR(TRIM(RIGHT(RC1,LEN(RC1)-(FIND(""-"",RC1)))),0),IFERROR(TRIM(RIGHT(RC2,LEN(RC2)-(FIND(""-"",RC2)))),0),IFERROR(TRIM(RIGHT(RC3,LEN(RC3)-(FIND(""-"",RC3)))),0),IFERROR(TRIM(RIGHT(RC4,LEN(RC4)-(FIND(""-"",RC4)))),0),IFERROR(TRIM(RIGHT(RC5,LEN(RC5)-(FIND(""-"",RC5)))),0),IFERROR(TRIM(RIGHT(RC6,LEN(RC6)-(FIND(""-"",RC6)))),0),IFERROR(TRIM(RIGHT(RC7,LEN(RC7)-(FIND(""-"",RC7)))),0))"
            Next x
        Next r
        
        .Columns("H:H").HorizontalAlignment = xlCenter
        .Range("H34:H38,H28:H32,H22:H26,H16:H20,H10:H14,H4:H8").Font.Color = vbWhite
        
        If .Range("A33").Value = "" Then .Range("A33").Offset(0, 0).Resize(6, 8).EntireRow.Delete
        
        If .Range("A27").Value = "" Then .Range("A27").Offset(0, 0).Resize(6, 8).EntireRow.Delete
        
    End With
    
End Sub

[mperrah]

Also, not familiar with database tables re: post #9
how would I set that up and utilize it?
Are you suggesting making a single sheet with 1 calendar to load instead of a new sheet for each month? or is the database invisible like an array?
and how many rows do I use for each week? 1 for the day number and 1 for the bills? or do the rows expand based on number of bills?
Sorry so many questions, your ideas are exciting and I would like to get them working for my project.

[mperrah]

Trying this application of SamT's code.
This errors on "Find" not defind.
In my sheet formula it finds the "-" in the string and pulls the number from whats to the right. (post #17) is the whole code.
Not sure how to manipulate this?

Public Function BillsTotal(WeeksCells As Range) As Double
' I3 = "=BillsTotal(A3:G3)"
    Dim Result As Double
    Dim Bills As Variant
    Dim Bill As String
    Dim Cel As Range
    For Each Cel In WeeksCells
        Bills = Split(Cel.Value, vbLf)
        For i = LBound(Bills) To UBound(Bills)
            Bill = Bills(i)
             NumberFromBill = Trim(Right(Bill, Len(Bill) - (Find("" - "", Bill))))
            Result = Result + NumberFromBill
        Next i
    Next Cel
    BillsTotal = Result
End Function

[mperrah]

Yessss, got it to work. !

Public Function BillsTotal(WeeksCells As Range) As Double
' I4 = "=BillsTotal(A4:G4)"
    Dim Result As Double
    Dim Bills As Variant
    Dim Bill As String
    Dim Cel As Range
    Dim NumberFromBill As Double
    Dim P1 As Integer
    For Each Cel In WeeksCells
        Bills = Split(Cel.Value, vbLf)
        For i = LBound(Bills) To UBound(Bills)
            Bill = Bills(i)
                
                    P1 = InStr(1, Bill, "-")
                    NumberFromBill = Trim(Right(Bill, Len(Bill) - P1))
                
            Result = Result + NumberFromBill
        Next i
    Next Cel
    BillsTotal = Result
End Function