build userform calendar using "cell counting" method looping named labels (SamT)

[mperrah]

How would I adapt this cell counting method to work on a userform where I have named the day number labels as dnum1, dnum2 etc... to dnum42 it's a 6 x 7 calendar



Option Explicit

Private CalendarTable As Range
Private FirstCalendarCell As Long

Function DaysInMonth(dDate As Date) As Long
DaysInMonth = Day(EOM(dDate))
End Function

Function EOM(dDate As Date) As Date
dDate = Format(dDate, "d-m-yyyy") 'Adjust as needed per your System and Locale
EOM = DateAdd("d", -1, DateValue(Month(dDate) + 1 & "-1-" & Year(dDate)))
End Function

Function FirstWeekDayOfMonth(dDate As Date) As Long
FirstWeekDayOfMonth = Weekday(Month(dDate) & "-1-" & Year(dDate))
End Function

Sub Initialize_CalendarTable()
Const SinglesPrefix As String = " " 'One space less than cell with
Const DoublesPrefix As String = " " 'two spaces less than cell with

Dim c As Long
Dim D As Long

Set CalendarTable = Range("B3:H8") ' myCal_label_array? ufCal.dnum1 to ufCal.dnum42
FirstCalendarCell = FirstWeekDayOfMonth(Range("B1")) ' myDate = ufCal.uMonth.Caption & "-" & ufCal.uYear.Caption
Application.EnableEvents = False

D = FirstCalendarCell - 1
With CalendarTable ' myCal_label_array? - userform name is ufCal
.Cells.ClearContents ' loop all ufCal.dnum1 - ufCal.dnum42 and clear caption
For c = 1 To DaysInMonth(Range("B1")) ' myDate
.Cells(D + c).Value = c & vbLf ' dnum & D + c & .caption = c... or dnum(D +c).caption...
Next c
End With

Application.EnableEvents = True
End Sub

[SamT]

Sub Initialize_CalendarTable()
'Also see Sub UserForm_Initialize()

'Const SinglesPrefix not needed with UserForm
'Const DoublesPrefix not needed
'
'in Design mode Set Day Labels TextAlign Property = Right
'Hint: hold Ctrl key down to select all labels, then set the property for all at once

Dim c As Long
Dim D As Long
Dim MyDate As Date

MyDate = CDate("1-" & ufCal.uMonth.Caption & "-" & ufCal.uYear.Caption)
'D = zero reference of Days of month
D = FirstWeekDayOfMonth(MyDate) - 1

'clear captions 'Hint: Set Captions to "" In design mode instead.
For c = 1 To 42
Me.Controls("dnum" & c).Caption = ""
Next c

'Set Captions
For c = 1 To DaysInMonth(MyDate) ' myDate
Me.Controls("dnum" & D + c).Caption = c
Next c

End Sub


Sub UserForm_Initialize()
'Assumes Design Mode changes made as above

Dim c As Long
Dim D As Long
Dim MyDate As Date

MyDate = CDate("1-" & ufCal.uMonth.Caption & "-" & ufCal.uYear.Caption)
'D = zero reference of Days of month
D = FirstWeekDayOfMonth(MyDate) - 1

'Set Captions
For c = 1 To DaysInMonth(MyDate)
Me.Controls("dnum" & D + c).Caption = c
Next c
End Sub

[mperrah]

Stroke of genious!
Me.Controls("dnum" & c).Caption = "" was the part I was missing! thank you.

One thing I noticed though,
When I alter the uMonth date and run the intialize_calendar, the first day of month doesnt change?

Here is my file if you want to see the form I'm working with.
I copied much of the code from the worksheet version you helped me with, so sorry for the duplication..
14363

[mperrah]

I found it, I'm in USA where we use m-d-yyyy


Sub fill_ufCal_dnum()
'Also see Sub UserForm_Initialize()
Dim c As Long
Dim D As Long
Dim MyDate As Date

MyDate = CDate(ufCal.uMonth.Caption & "-1-" & ufCal.uYear.Caption) ' was - MyDate = CDate("1-" & ufCal.uMonth.Caption & "-" & ufCal.uYear.Caption)
'D = zero reference of Days of month
D = FirstWeekDayOfMonth(MyDate) - 1

'clear captions 'Hint: Set Captions to "" In design mode instead.
For c = 1 To 42
Me.Controls("dnum" & c).Caption = ""
Next c

'Set Captions
For c = 1 To DaysInMonth(MyDate) ' myDate
Me.Controls("dnum" & D + c).Caption = c
Next c

End Sub

[mperrah]

Thank you SamT
You are phenomenal!

[mperrah]

I was premature in my victory ;(
I got the start day working but December is still acting as the month and day are reversed - or wrong.


Option Explicit

Private CalendarTable As Range
Private FirstCalendarCell As Long

Function DaysInMonth(dDate As Date) As Long
dDate = Format(dDate, "m-d-yyyy")
DaysInMonth = Day(EOM(dDate))
End Function

Function EOM(dDate As Date) As Date
dDate = Format(dDate, "m-d-yyyy") 'Adjust as needed per your System and Locale
EOM = DateAdd("d", -1, DateValue(Month(dDate) + 1 & "-1-" & Year(dDate))) ' this part I'm not sure if I have it correct?
End Function

Function FirstWeekDayOfMonth(dDate As Date) As Long
dDate = Format(dDate, "m-d-yyyy")
FirstWeekDayOfMonth = Weekday(Month(dDate) & "-1-" & Year(dDate))
End Function

Sub UserForm_Initialize()
Dim lbtarget As MSForms.ListBox
Dim rngSource As Range
Dim lrB As Integer
Dim wsB As Worksheet
Dim c As Long
Dim D As Long
Dim MyDate As Date

MyDate = Format(MyDate, "m-d-yyyy")

Set wsB = Sheets("Bills")
lrB = wsB.Cells(Rows.Count, 2).End(xlUp).Row
Set rngSource = wsB.Range("B2:D" & lrB)

Me.uMonth.Caption = wsB.Range("cMonth").Value
Me.sMonth.Value = wsB.Range("cMonth").Value

Me.uYear.Caption = wsB.Range("cYear").Value
Me.sYear.Value = wsB.Range("cYear").Value

Set lbtarget = ufCal.lbBills
With lbtarget
.ColumnCount = 3
.ColumnWidths = "72;42;32"
.List = rngSource.Cells.Value
End With

MyDate = CDate(ufCal.uMonth.Caption & "-1-" & ufCal.uYear.Caption)

D = FirstWeekDayOfMonth(MyDate) - 1

For c = 1 To DaysInMonth(MyDate)
ufCal.Controls("dnum" & D + c).Caption = c
Next c

End Sub

Sub fill_ufCal_dnum()
'Also see Sub UserForm_Initialize()
Dim c As Long
Dim D As Long
Dim MyDate As Date

MyDate = Format(MyDate, "m-d-yyyy")

MyDate = CDate(ufCal.uMonth.Caption & "-1-" & ufCal.uYear.Caption)
'D = zero reference of Days of month
D = FirstWeekDayOfMonth(MyDate) - 1

'clear captions 'Hint: Set Captions to "" In design mode instead.
For c = 1 To 42
ufCal.Controls("dnum" & c).Caption = ""
Next c

'Set Captions
For c = 1 To DaysInMonth(MyDate) ' myDate
ufCal.Controls("dnum" & D + c).Caption = c
Next c

End Sub

[SamT]

Try this format
"d-mmm-yy"

[mperrah]

that made it worse.
The calendar only shows the first day.
I changed to m-d-yyyy to get the calendar to populate all but december (stops on the 12th again)

[SamT]

Mark,

I actually looked at your code this time and I notice that in subs UserForm_Initialize and fill_ufCal_dnum you are setting the format of myDate way at the top. That is no good, because when you actually assign a value later in the sub, it takes on the format in which you assign the value.

That should not matter because I wrote those three Functions to handle any date input to them in any format.

Anyway, try this new EndOf Month function

Function EOM(dDate As Date) As Date
dDate = DateAdd("m", 1, dDate)
EOM = DateAdd("d", -1, DateValue(Month(dDate) & "-1-" & Year(dDate)))
End Function

I brainfarted that Month(Date) + 1 does not return a valid number (1) when month = 12

[snb]

I'd reduce the Initialize code to:


Sub UserForm_Initialize()
With Sheets("Bills")
lbBills.List = .Cells(1).CurrentRegion.Offset(1, 1).SpecialCells(2).Value

sMonth.Value = Sheets("Bills").Range("cMonth").Value
sYear.Value = Sheets("Bills").Range("cYear").Value
End With

For j = 1 To Day(DateAdd("m", 1, DateSerial(sYear, sMonth, 1)) - 1)
Me("dnum" & Weekday(DateSerial(sYear, sMonth, 1)) + j - 1).Caption = j
Next
End Sub

In design mode you can put the lbBills property columncount to 3 and columnwidth to 72;42;30

[SamT]

@ snb,

Nice code.

Why didn't you assign the zero day value to a variable outside the loop? Wouldn't it be faster?



@ Mark,

Your UserForm Calendar would be a nice addition to the KB after you get it working, perfected, and cleaned up. Why don't you submit it to the Potential KB Entries Folder when it's working and we will help you perfect and generalize it.

[snb]

I rewrote the userform code.

[mperrah]

Thank you snb and SamT, yet again.

snb: The dates for december are working correctly, awesome. I noticed the user form code does some sorting on the sheet when i click the lbList Labels that I think triggers a sheet change event I use to make the line numbers and coloring to update as user adds or removes lines, causing several sorts to take place. I will focus on getting the sorting straightened out then we can look at streamlining everything and cleaning up the interface. My doe added zeros to sort the due date, but it keeps adding an extra zero each time you press it. need to find a way to eliminate the extra zero after the sort. I will try to incorporate your method.
I like the look of making a single sort function that we can pass the list index too, cool.

SamT: That EOM code did the trick.
I have the code working to insert the bills into the calendar now too.
And the payday hi lights ( 1st and 15th ) now is working - I am considering adding 3 options for paydays - every friday, every other friday or 1 and 15th. maybe check box. Currently I'm fixing the weekly sum feature, this will be a challenge (as if all before this was a cake walk, lol - thank you for the help)

I would love to have this project submitted for the KB, I would add the sheet based version I made too as an option, there is a lot of neat and efficient coding we used there. I started this project using formulas without vb so it could work on a microsoft surface RT tablet. We could add that as well.
I'll update with my next stage of progress - thanks to you both.
-mark

[mperrah]

14377
This has snb's code for initializing and SamT's for EOM calculating plus mine to insert bills on the user form.
Still working on the weekly sums, and choosing options to let user select what days to highlight for paydays. weekly. eow, bi-monthly.
Next step will be formatting to print.
Thank you again for your help.:bow:

[snb]

A new version

[mperrah]

Thank you snb!
The sorting is awesome.
I hadn't noticed why you removed the Mod button from the userform until I was commenting all the subs and noticed what you did.
When we select an item in the bill list its values are available in the entry box above. changing those values updates the list values, nicely done!

I added the routine to sum the bills by week.



Sub addSums_UF()
Dim Result, BillsTotal As Double
Dim Bills As Variant
Dim Bill As String
Dim b, x As Long
Dim P1, NumberFromBill

With ufCal
If .cb_sums.Value = True Then
z = 1
For y = 0 To 35 Step 7
Result = 0
For x = 1 To 7
For b = 0 To .Controls("dcell" & x + y).ListCount - 1
Bill = .Controls("dcell" & x + y).List(b)
P1 = InStr(1, Bill, "-")
NumberFromBill = Trim(Right(Bill, Len(Bill) - P1))
Result = Result + NumberFromBill
Next b
Next x
.Controls("sum" & z).Caption = Result
z = z + 1
Next y

Else
For z = 1 To 6
.Controls("sum" & z).Caption = ""
Next z
End If

End With

End Sub


I am still having issues with the bills values in the lbList being added or removed from the dcell after the lbList has been altered after initialization.

If I add, remove or modify the values in the lbList then add the bills to the dcells the list is representative of the intialized values, not the current values.
How do I take the current values in the lbBills list to fill the dcells? - not the initialized values

[mperrah]

14386
Here is the current file with each routine commented with explanation.
Altering the lbBill list and then using that list to copy from listbox (lbBills) to listbox(dcell1 to 42) results in the intialized values being copied, not current values if they have been modified.

[mperrah]

Strange, when I click due to sort by due day, then remove and add bills to dcell1-dcell42 the correct info gets applied?!

Also snb:
I'm not sure where to modify your M-Cal code to put a "-" in between the bill name and b ill amount.
My code for summing looks for the "-" to know where the numbers begin...




Sub M_cal()
'thanks to snb this sets the day captions and fills the day listboxes with the bills for that day
For j = 0 To UBound(lbBills.List)
c00 = c00 & vbCrLf & Join(Application.Index(lbBills.List, j + 1), "|")
Next
sn = Split(c00 & vbCrLf, vbLf)

For j = 1 To 42
Me("dcell" & j).Clear
Me("dnum" & j).Caption = IIf(j < Weekday(DateSerial(sYear, sMonth, 1)) Or j > Weekday(DateSerial(sYear, sMonth, 1)) + Day(DateSerial(sYear, sMonth + 1, 0)) - 1, "", j - Weekday(DateSerial(sYear, sMonth, 1)) + 1)
If Me("dnum" & j).Caption <> "" And UBound(Filter(sn, "|" & Me("dnum" & j).Caption & vbCr)) > -1 Then Me("dcell" & j).List = Split(Join(Filter(Split(Join(Filter(sn, "|" & Me("dnum" & j).Caption & vbCr), "|~"), "|"), vbCr, False)), "~") ' i'm guessing its somewhere in here
Next
End Sub

[snb]

to sum the bills per week a oneliner suffices:


Sub M_cal()
For j = 0 To UBound(lbBills.List)
c00 = c00 & vbCrLf & Join(Application.Index(lbBills.List, j + 1), "|")
Next
sn = Split(c00 & vbCrLf, vbLf)

For j = 1 To 42
If j < 7 Then Me("sum" & j).Caption = ""
Me("dcell" & j).Clear
Me("dnum" & j).Caption = IIf(j < Weekday(DateSerial(sYear, sMonth, 1)) Or j > Weekday(DateSerial(sYear, sMonth, 1)) + Day(DateSerial(sYear, sMonth + 1, 0)) - 1, "", j - Weekday(DateSerial(sYear, sMonth, 1)) + 1)

If Me("dnum" & j).Caption <> "" And UBound(Filter(sn, "|" & Me("dnum" & j).Caption & vbCr)) > -1 Then
Me("dcell" & j).List = Split(Join(Filter(Split(Join(Filter(sn, "|" & Me("dnum" & j).Caption & vbCr), "|~"), "|"), vbCr, False)), "~")
Me("sum" & (j - 1) \ 7 + 1).Caption = Val(Me("sum" & (j - 1) \ 7 + 1).Caption) + Evaluate("0+" & Join(Filter(Split(vbCr & Join(Filter(sn, "|" & Me("dnum" & j).Caption & vbCr), vbCr & "|" & vbCr), "|"), vbCr, False), "+"))
End If
Next
End Sub

other questions answered in the attachment

[mperrah]

you make it look so simple - oneliner king

Here I'm mostly done with the payday radio button,
working on calculating odd even weeknumbers to know which friday is everyother friday.14391


Function WeekNum(DT As Date) As Long
WeekNum = Int(((DT - DateSerial(Year(DT), 1, 0)) + 6) / 7)
End Function

Sub addPayDay_EoF() ' every friday
'makes every friday day captions Bold when the radio button is active
Dim D, s, x As Integer
Dim myDate As Date

With ufCal
For x = 1 To 42
.Controls("dnum" & x).Font.Bold = False
Next x
myDate = .uMonth.Caption & "-1-" & .uYear.Caption
D = FirstWeekDayOfMonth(myDate) - 1
If (WeekNum(myDate) Mod 2) = 0 Then
MsgBox ("EvenWeek")
For s = 12 To 41 Step 14
.Controls("dnum" & s).Font.Bold = True
Next s
Else
MsgBox ("OddWeek")
For s = 6 To 41 Step 14
.Controls("dnum" & s).Font.Bold = True
Next s
End If
End With
End Sub

[snb]

I think this might be sufficient:


Sub M_cal()
For j = 0 To UBound(lbBills.List)
c00 = c00 & vbCrLf & Join(Application.Index(lbBills.List, j + 1), "|")
Next
sn = Split(c00 & vbCrLf, vbLf)

For j = 1 To 42
If j < 7 Then Me("sum" & j).Caption = ""
Me("dcell" & j).Clear
Me("dnum" & j).Caption = IIf(j < Weekday(DateSerial(sYear, sMonth, 1)) Or j > Weekday(DateSerial(sYear, sMonth, 1)) + Day(DateSerial(sYear, sMonth + 1, 0)) - 1, "", j - Weekday(DateSerial(sYear, sMonth, 1)) + 1)


If j Mod 7 = 6 Then Me("dnum" & j).Font.Bold = cb_paydays.Value


If Me("dnum" & j).Caption <> "" And UBound(Filter(sn, "|" & Me("dnum" & j).Caption & vbCr)) > -1 Then
Me("dcell" & j).List = Split(Join(Filter(Split(Join(Filter(sn, "|" & Me("dnum" & j).Caption & vbCr), "|~"), "|"), vbCr, False)), "~")
Me("sum" & (j - 1) \ 7 + 1).Caption = Val(Me("sum" & (j - 1) \ 7 + 1).Caption) + Evaluate("0+" & Join(Filter(Split(vbCr & Join(Filter(sn, "|" & Me("dnum" & j).Caption & vbCr), vbCr & "|" & vbCr), "|"), vbCr, False), "+"))
End If
Next
End Sub

Private Sub cb_paydays_Change()
M_cal
End Sub

BTW it's not a radiobutton (OptionButton) but a CheckBox.

[mperrah]

Thank you snb,
I had worked out a routine for every friday as yours does (much more nicely than mine for sure)
I was stumped with every other friday.
I was able to mark every other friday starting from the first friday of each month,
but paydays I believe start the first friday of the year and are every other friday from there, which might be the second friday of some months instead of the first. So I came up with a test to see if the current month starts on an even or odd week number of the year, then I am trying to see how to apply that to the selected months week

here are the three sub's I have so far, I put them in a frame with option buttons to trigger ob_Fridays, ob_EoF, ob_BiMonth



Function WeekNum(DT As Date) As Long
WeekNum = Int(((DT - DateSerial(Year(DT), 1, 0)) + 6) / 7)
End Function
Sub addPayDay_BiMonth() ' bi monthly
'makes the 1st and the 15th of the month day captions Bold when the check box is active
Dim D, x As Integer
Dim myDate As Date

With ufCal
For x = 1 To 42
.Controls("dnum" & x).Font.Bold = False
Next x
myDate = .uMonth.Caption & "-1-" & .uYear.Caption
D = FirstWeekDayOfMonth(myDate) - 1
.Controls("dnum" & D + 1).Font.Bold = True
.Controls("dnum" & D + 15).Font.Bold = True
End With
End Sub
Sub addPayDay_fridays() ' every friday
'makes every friday day captions Bold when the radio button is active
Dim D, x As Integer
Dim myDate As Date

With ufCal
For x = 1 To 42
.Controls("dnum" & x).Font.Bold = False
Next x
For s = 6 To 41 Step 7
.Controls("dnum" & s).Font.Bold = True
Next s
End With
End Sub
Sub addPayDay_EoF() ' every friday
'makes every friday day captions Bold when the radio button is active
Dim D, s, x As Integer
Dim myDate As Date

With ufCal
For x = 1 To 42
.Controls("dnum" & x).Font.Bold = False
Next x
myDate = .uMonth.Caption & "-1-" & .uYear.Caption
D = FirstWeekDayOfMonth(myDate) - 1
If (WeekNum(myDate) Mod 2) = 0 Then
MsgBox ("EvenWeek")
For s = 12 To 41 Step 14
.Controls("dnum" & s).Font.Bold = True
Next s
Else
MsgBox ("OddWeek")
For s = 6 To 41 Step 14
.Controls("dnum" & s).Font.Bold = True
Next s
End If
End With
End Sub

[mperrah]

Also your latest routine stopped at:
If j Mod 7 = 6 Then Me("dnum" & j).Font.Bold = cb_paydays.Value

I changed the end to True and it completed but marked every friday, where I was looking to do every other.
My goal is to have the three options listed in my last post that the user can select: Fridays, EoF, and BiMonthly.

Sub M_cal()
For j = 0 To UBound(lbBills.List)
c00 = c00 & vbCrLf & Join(Application.Index(lbBills.List, j + 1), "|")
Next
sn = Split(c00 & vbCrLf, vbLf)

For j = 1 To 42
If j < 7 Then Me("sum" & j).Caption = ""
Me("dcell" & j).Clear
Me("dnum" & j).Caption = IIf(j < Weekday(DateSerial(sYear, sMonth, 1)) Or j > Weekday(DateSerial(sYear, sMonth, 1)) + Day(DateSerial(sYear, sMonth + 1, 0)) - 1, "", j - Weekday(DateSerial(sYear, sMonth, 1)) + 1)

If j Mod 7 = 6 Then Me("dnum" & j).Font.Bold = True 'cb_paydays.Value

If Me("dnum" & j).Caption <> "" And UBound(Filter(sn, "|" & Me("dnum" & j).Caption & vbCr)) > -1 Then
Me("dcell" & j).List = Split(Join(Filter(Split(Join(Filter(sn, "|" & Me("dnum" & j).Caption & vbCr), "|~"), "|"), vbCr, False)), "~")
Me("sum" & (j - 1) \ 7 + 1).Caption = Val(Me("sum" & (j - 1) \ 7 + 1).Caption) + Evaluate("0+" & Join(Filter(Split(vbCr & Join(Filter(sn, "|" & Me("dnum" & j).Caption & vbCr), vbCr & "|" & vbCr), "|"), vbCr, False), "+"))
End If
Next
End Sub

[snb]

Your payday criterion is fuzzy, so I won't be able to create an algorithm.

[mperrah]

Sorry about the fuzz... :)

My thoughts are to find the first Friday of the year,
which falls in the first week of the year Weeknumber - 1
then every 14 days after that is the Friday day to make Bold if the user picks Every other Friday- regardless of month
-with my research it looks like if the week number is odd (1, 3, 5 etc) would be the Friday we are looking for...

If they choose every Friday: every day 6 of the week gets Bold

If they choose bi-monthly: the 1st and 15th regardless of day of week gets Bold
(optionaly, it would be nice to pick the Friday before a weekend if the 1st or 15th falls on a weekend)

[snb]

It depends on which system you use: I prefer the ISO-weeknumber (because it's an International standard), not the US weeknumber.

every fourth friday in an ISO system


sn= [date(2015,1,4)-weekday(date(2015,1,4),2)+5+28*(row(1:13)-1)]

[mperrah]

14399
This has the option buttons and the check boxes working
still ironing out the every other friday, but making progress. :yes

[mperrah]

I was reading about the ISO version and I'm no sure which to go with.
I suppose to make this more universal for each end users needs, another option could be in order...
It could be a checkbox next to or in the payday options frame..
then based on their choice it fires the correct routine.

Since I (we) have overcome so many region specific date formatting issue, maybe that should be an option too.
A drop down with 3 or 4 date local formatting options, that are a variable used in the functions.
opt1: "m" - d- yyyy
opt2: d - "m"' - yyyy
opt3: yyyy - "m" - d
opt4: yyyy - d - "m"

[snb]

The ISO formattting (the only sensible one) is yyyy mm dd (i.e. small endian).

Please refrain form using 'Call'; it's utterly redundant.

I don't see any need for the checkbox 'Bills'.
I assume the bills should be presented in the 'calendar' anyway: so it's part of M_cal.(no need for a separate routine).

I have no idea what advantage is the use of 'payday' (a concept I am not familiar with and I fear is a local custom somewhere.).

[mperrah]

You make a great point on the bills being included by default.

I had started with making a calendar to print out for the fridge to know when bills are coming up, and it blossomed (snowballed) into this.

As we accomplished each stage of progress I looked at making each piece modular and so a toggle option made sense.
But as you astutely point out, some parts make no sense to be omitted for a "bill scheduling" calendar.

as far as the 'paydays' (you made me laugh hard - thank you)
I still have a day job (thankfully) and seeing the weekly totals coming up and seeing when the next income helps with planning.

My wife was paid every other Friday - until she quit her job :( mine is bi-monthly - for now,
and I have friends that are every Friday
so I was attempting to make this useful for as many as possible.

I guess it doesn't really matter the date formatting in the background if they are from a label caption or spinner value anyway.
It just needs to accommodate the system default of the user's region I suppose

[SamT]

There are a great variety of payday schemes. I have been paid on Thursdays, Fridays, Mondays, Every two weeks, the 1st and 3rd weeks of the month, (interesting when a month has 5 weeks,) the 1st, the last day of the month and now, midnight of the 1st and midnight of the 3rd, except when those dates fell on a non-work day, then it is midnight of the last working day previous, and I know others who receive their monthly stipend on some other particular date, including one who was "paid" quarterly.

For your purposes, I would ignore the Non-Workday situation and let those who have to deal with it just make the mental adjustment when needed.

[snb]

In that case I think it might be wiser to give the opportunity to enter the amount of money in the bank account (I hope you won't be paid cash) at the start of the month. Now the bill calendar can calculate the saldo in the account each day of the month. I think that is more informative than the summing of bills per week.
If you add a means to enter incoming amounts and the days it will be received, you'll have a perfect day-to-day cash flow management tool, even on the fridge.

[mperrah]

You have a way knack for getting to the best part of an idea.
I hadn't realized that this is really what I'm after all along.
To know how much is available is more helpful then knowing what's about to leave.
So if we add a text box it the top next to the date for Current available funds,
Then subtract all the bills and show the remaining available balance.
Add functionality for debits and deposits to be added at any given day.
This will need more daily updating, but the usefulness has grown exponentially.

I'll rethink the layout, but I'm excited about the opportunity.
We should make a mobile app out of this...

[mperrah]

I'm still planning a reformat of the userform, but I am driven to figure out Bolding every other Friday.
I think I'm close with this, but it errors on


If (thisF - F1) Mod 2 = 0 Then
saying type mismatch, runtime error 13

Sub weeksEoF()
Dim T1, r
Dim thisF, F1 As Date

With ufCal
F1 = ("Jan-1-" & .uYear.Caption)

If Weekday(F1) = 7 Then
'FirstPastFriday = True
'first weekday is a saturday so loook for odd weeks to bold
End If

If .dnum6.Caption <> "" Then
T1 = .dnum6.Caption
Else
T1 = .dnum13.Caption
End If

thisF = .uMonth.Caption & "-" & T1 & "-" & .uYear.Caption

If (thisF - F1) Mod 2 = 0 Then
For r = 6 To 34 Step 7
.Controls("dnum" & r).Font.Bold = True
Next r
Else
For r = 13 To 41 Step 7
.Controls("dnum" & r).Font.Bold = True
Next r
End If
End With
End Sub

[snb]

use:


If j Mod 14 = 6 Then Me("dnum" & j).Font.Bold = cb_paydays.Value

[SamT]

Controls:

Payday Options Frame
List boxes w/2+ columns, Column 1, Bound and hidden:

lbFrequency; C3 = Weekly, SemiWeekly, BiMonthly, Monthly, quarterly,etc; C1 = other listbox names, C2, hidden = Frequency Number
lbPayday_Day, C2 = Sun to Sat, C1 = 1 to 7
lb1stPayday_Date, lb2ndPayday. for bimonthly; Might use lbPayday_Day
lbPayday_Date C1 = 1 to 31, for monthly




Stack the listboxes with lbFrequency on top.

lbFrequency change
Freq = lbFrequency.Column(1) 'Count from zero
Controls(lbFrequency.Value).ZOrder = fmtop

Assume Weekly or semiweekly, lbPayday_Day on top. Assume Wednesday selected, lbPayday_Day = 4


pd = LbPayday_Day.Value
if pd => FirstdayofMonth Then .Controls("dnum" & pd).Font.Bold = True
Do While pd < 43
pd = pd + (7 * Freq)
.Controls("dnum" & pd).Font.Bold = True
Loop

[mperrah]

Thank you samT,

I was trying to implement snb's and thought I was getting closer:
this is not consistent... only worked on January



Function YearDay(dat As Date) As Integer
YearDay = DateDiff("d", CDate("1/1/" & Year(dat)), dat) + 1
End Function


Sub pdEoF()
' Bolds every other Friday form the second week of the year
Dim x, D As Long
Dim tDay As Date
Dim myDate As Date

With ufCal
For x = 1 To 42
.Controls("dnum" & x).Font.Bold = False
Next x

myDate = .uMonth.Caption & "-1-" & .uYear.Caption
D = FirstWeekDayOfMonth(myDate) - 1

For x = 6 To 41 Step 7
If .Controls("dnum" & x).Caption <> "" Then
tDay = DateValue(Month(.uMonth.Caption) & "-" & Day(.Controls("dnum" & x).Caption) & "-" & Year(.uYear.Caption))
If YearDay(tDay) Mod 14 = 6 Then
.Controls("dnum" & x).Font.Bold = True
End If
End If
Next x
End With

End Sub

I will work on formatting the form to accommodate you ideas too. - keep em coming :)

[SamT]

On further consideration, the Payday Options I mentioned before will not work with semi-weekly Frequency. You will need to store the Last Payday Date (in a hidden sheet "VBA_Variables") and refer to it in the emboldening loop

An easy way to refer to the Date of the dnum Controls is to set their Tag Property to the date (1-31)

PD = VBA_Variables.LastPayday_Date
'See code far below for alternate loop math
Do while Month(DateAdd(ww, 2, PD) = Month(ThisCalendar)
PD = (DateAdd(ww, 2, PD)
For Each Ctrl in .Controls
If Ctrl.Tag = Day(PD) Then 'Assumes that only dnum controls have values 1 to 31
Ctrl.Font.Bold = True
Exit For 'Skip rest of controls during this loop
End If
Next Ctrl
Loop
VBA_Variables.LastPayday_Date = PD

Sometimes when I have to deal with a group controls many times, I will use the following structure. snb also has a neat way of doing this.


Dim DateCells As Collection
'While setting the Date values of the dnum Captions and Tags
DateCells.Add Ctrl, Ctrl.Tag 'Only add the active dnum controls


Now you can loop thru DateCells Collection to access each used dnum control or you can

PD = DateAdd(ww, 2,VBA_Variables.LastPayday_Date)
Do while Month( PD) = Month(ThisCalendar)
DateCells(PD).Font.Bold = True
LastPD = PD
PD = DateAdd(ww, 2, PD)
Loop
VBA_Variables.LastPayday_Date = LastPD

[mperrah]

still designing userform, but
I tweaked this sub into a function to find the second friday of the year,
now I think we can use this as part of the semi-weekly routine.

Function secondFriday(TDay As Date) As Date
Dim FirstDayOfYear As Date
Dim iWeekDay As Integer
Dim SecondFridayOfYear As Date
Const FridayNumber = 12
TDay = Date
FirstDayOfYear = DateSerial(Year(TDay), 1, 1)
iWeekDay = Weekday(Date:=FirstDayOfYear, FirstDayOfWeek:=vbMonday)
SecondFridayOfYear = DateSerial(Year(FirstDayOfYear), _
1, _
1 + IIf((FridayNumber - iWeekDay) < 0, FridayNumber - iWeekDay + 7, FridayNumber - iWeekDay))
secondFriday = SecondFridayOfYear
End Function

[mperrah]

Finally got the SemiWeekly working correctly! yeah



Function FirstWeekDayOfMonth(dDate As Date) As Long
'thanks to SamT thisd lets us know what day of the week the 1st of the month falls on
FirstWeekDayOfMonth = Weekday(Month(dDate) & "-1-" & Year(dDate))
End Function

Function myWeekNum(DT As Date) As Long
DT = Format(DT, "m-d-yyyy")
myWeekNum = Int(((DT - DateSerial(Year(DT), 1, 0)) + 6) / 7)
End Function

Sub pd_EoF()
' Bolds every other Friday form the second week of the year
Dim x, D As Long
Dim TDay As Date
Dim myDate As Date

With ufCal
For x = 1 To 42
.Controls("dnum" & x).Font.Bold = False
Next x

myDate = .uYear.Caption & "-" & .uMonth.Caption & "-1"
D = FirstWeekDayOfMonth(myDate) - 1

For x = 6 To 41 Step 7
If .Controls("dnum" & x).Caption <> "" Then
TDay = DateValue(Year(.uYear.Caption) & "-" & Month(.uMonth.Caption) & "-" & Day(.Controls("dnum" & x).Caption))
If myWeekNum(TDay) Mod 2 = 0 Then
Else
.Controls("dnum" & x).Font.Bold = .ob_EoF.Value
End If
End If
Next x
End With

End Sub

Sub pd_select()
With ufCal

If .Controls("ob_Fridays").Value = True Then
pd_Fridays
ElseIf .Controls("ob_EoF").Value = True Then
pd_EoF
ElseIf .Controls("ob_BiMonth").Value = True Then
pd_BiMonth
ElseIf .Controls("ob_Off").Value = True Then
pd_Off
End If

End With
End Sub

' on the UserForm:
Private Sub ob_BiMonth_Click()
'if the Bi-monthly payday radio button is selected the 1st and 15th day numbers will be Bold
pd_BiMonth
End Sub

Private Sub ob_EoF_Click()
pd_EoF
End Sub

Private Sub ob_Fridays_Click()
pd_Fridays
End Sub

Private Sub ob_Off_Click()
pd_Off
End Sub

Private Sub sMonth_Change()
'when the up or down arrow is clicked change the Month and update the calendar day numbers and bill dates
uMonth.Caption = sMonth
m_Cal
pd_select
End Sub

Private Sub sYear_Change()
'when the year up or down arrows are clicked update the calendar days and bill days
uYear.Caption = sYear
m_Cal
pd_select
End Sub

[mperrah]

14423
Here is the working file
Need to add back the frame around payday options.. but this is working well thanks to SamT and snb.

I will pursue the idea of making a cash flow management tool.
I started tweaking this one but I think it will need a major overhaul.

So for now a huge thank you to helping me bring this idea to working awesomeness.
-mark

[mperrah]

BTW: snb
I now understand what your code was doing:


.Controls("dnum" & x).Font.Bold = .ob_EoF.Value

I just had to add the "." or ufCal in front to get it to work...
So if the option button was checked it would bold the caption,
so my whole IF statement was not even necessary.
very nice one liner for sure.
I will be implementing this practice in past and future projects.
thank you

[mperrah]

Only thing I can get is now if we display May, i get bold on the 1st, 8th and 22nd
the first is correct but then should be 15th and 29th ?
I combed through the code top to bottom and tried formating m-d-yyyy or yyyy-m-d or yyyy-d-m or "m" -d-yyyy.
This is baffling

If you look at the VBA_Variables page you can see the code testing seems to work, (Column AG and AF)
but translation to the userform falls short

[SamT]

Function WeekNum(dDate As Date) As Long
'Returns the number of the week of the year of dDate
WeekNum = CLng(DateDiff("ww", dDate, "1-1" & Year(dDate)))
End Function

Suggest you set the spinbutton min property = 0 and max property = 13. On Changing, If Value = Min Then Value = 12. If Value = Max then value = 1. This will give a Rollover quality to it. I also would use an "Update" command button instead of using the SpinButton change event. Otherwise, the screen will flicker a lot if the user "spins" several months (or years.)



Who says that pay days start on the second Friday of the year?
One year, the last payday was 12 days before New Year's Day. Now I gotta wait yet another 2 weeks to get paid again? :crying:

That is why I recommended storing the date of Last payday. Once initiated, it is eternal and covers any weekday payday. By also storing periodicity, and using it as a multiplier, one routine handles getting paid every 1 week, 2 weeks, ... 20 weeks. all you have to add is a check for holidays and the option to be paid before or after such.

I have been paid weekly on days other than Fridays. Payday is at the convenience of the employer, not by some universal rule.

[mperrah]

So add a year change if spin down and month is 0 - year
and if spin up +1 if month 12

[SamT]

:dunno It actually sounds good for this particular application.

How are you handling special one time bill planning? Say the User wants to add something one time 6 months in advance?

I am thinking of a bill scheduling form and Data sheet both with Date Due and Approximate amounts. The Data Sheet would have several tables: Monthly, semi-Monthly, Quarterly, Biannual (Great for Insurance payments,) Annual, and Special.

All would need a DayDue Column, Semi-monthly, Quarterly, Biannual, and Annual a month due number column, but Special only a Date Column.

SideBar:
Since all Collections use positional Keys, the first Item added to a Collection can be retrieved with Collection(1) and the Second Item with Collection(2) etc. This means you don't have to use any Control Tags as keys, just add them in Date order. This means that you can have your bill controls in another Collection accessible by Day number.

BTW, for the Bill controls, I would use two Column ComboBoxes, so as to both display the predicted value of the bill and allow the user to edit it on an unlimited, scrollable control. This would also facilitate updating the bill totals from estimated to actual.

If you were using Collections:
Sort the Monthly by DayDue, Loop thru the column and Access each Bill Control from its Collection by DayDue and add the bill to the Control.
Repeat for semimonthly, but check if ODD/Even matches the Current Calendar Month.
For Quarterly bills, just remember that in Mod 3 counting 1, 2, and 0 are Jan, Feb, and Mar, respectively [Month(March 1, '15) Mod 3 = 0]

SideBar:
Come to think of it all any of the tables need is a MonthDue, a DayDue, and approximate amount columns. Since Mod Counting always ends in 0, the MonthDue for monthly bills is 0 and the "MonthDue =value" for monthly bills is Month(CurrentMonth) Mod 1. For SemiMonthly bills its Month(CurrentMonth) Mod 2, (odd = 1, even = 0, Quarterlies is Month(CurrentMonth) Mod 3, Semiannuals is Month(CurrentMonth) Mod 6, (June and Dec = 0) and annuals is Month(CurrentMonth) Mod 12, Dec = 0.

This means that one procedure can read all the tables and add the appropriate bills to any Calendar month. Just change the Modulus value

Sub GetBills()
'Pseudocode
AddBills(MonthlyTable, ModDivisor:=1)
AddBills(SemiMonthlyTable, ModDivisor:=2)
AddBills(QuarterlyTable, ModDivisor:=3)
AddBills(SemiAnnualTable, ModDivisor:=6)
AddBills(AnnualTable, ModDivisor:=12)
AddBills(SpecialTable, ModDivisor:=12)
End Sub

The AddBills Routine checks Month(CurrrentMonth) Mod Modulus and compares it to the MonthDue column.

Sub AddBills(Table As Range, ModDivisorAs Long)
'PseudoCode
'Table Structure: Column1 = Bill name, 2 = Amount, 3 = DayDue, 4 = MonthDue
ModMonthDue = Month(currentMonth) mod ModDivisor
For each Row in Table
If .Cells(4) = ModMonthDueThen BillControls(.Cells(3)) AddItem Row
Next
End Sub

Of course you want the Bill Scheduling form to use Mod counting when assigning values to the Month due column

[mperrah]

I like this. We can use a users input + the 12 for the special modulus instead of just 12.
I will start building this, I will lean on you for userform comparability
the sheet manipulation should be straight foward but I'm very new with userforms and adapting for that is an exciting challenge. I really appreciate all the help and awesome ideas you are contributing.
It's like being a padawan with my own private Jedi academy

[mperrah]

So divide the frequency into 12 and have that be the multiplier. If it's yearly then just 12 and if it's once a year just need the start day. So we have 3 (or 4) variables: start day, frequency, holiday test, maybe end day. I think the modulus method will do great, just have the added qualifier for one time events.
For mortgages and car loans we can have a term variable for number of payments to help calculate end date

[SamT]

So divide the frequency into 12
I mistakenly used the term "modulus" as the divisor. In reality Modulus is the result, (the remainder,) of a Division by the Mod Operator.

1 Mod 2 = 1
2 Mod2 = 0
3 Mod 2 = 1
1 Mod 6 = 1
5 mod 6 = 5
6 Mod 6 = 0
7 Mod 6 = 1
11 Mod 6 = 5
12 Mod 6 = 0

For clarity, replace each instance of "Modulus" in my code above with "ModDivisor" and "MonthDue" with "ModMonthDue." Using the Prefix "Mod" to indicate that there is a relationship to the Mod Operator.

The AddBills Routine checks Month(CurrrentMonth) Mod ModDivisor and compares it to the ModMonthDue column. Note this routine is now complete

Sub AddBills(FreqTable As Range, ModDivisor As Long)
'Table Structure: Column1 = Bill name, 2 = Amount, 3 = DayDue, 4 = ModMonthDue
ModMonthDue = Month(currentMonth) Mod ModDivisor
For each Row In FreqTable
If .Cells(4) = ModMonthDue Then BillControls(.Cells(3)) AddItem Row
Next
End Sub

See Following Tables for Visual aid.



Monthly Bills Table: ModDivisor = 1


Name
Amount
DayDue
ModMonthDue



all Months
0





Semi-Monthly Bills Table: ModDivisor = 2


Name
Amount
DayDue
ModMonthDue



Jan,Mar,May
1



Jul,Sep,Nov
1



Feb,Apr,Jun
0



Aug,Oct,Dec
0





Quarterly Bills Table: ModDivisor = 3


Name
Amount
DayDue
ModMonthDue



Jan,Apr,Jul,Oct,
1



Feb, May,Aug,Nov
2



Mar,Jun,Sep,Dec
0





Semi-Annual Bills Table: ModDivisor = 6


Name
Amount
DayDue
ModMonthDue




Jan, Jul
1




Feb, Aug
2




Mar, Sep
3




Apr, Oct
4




May, Nov
5




Jun, Dec
0





Annual Bills Table: ModDivisor = 12


Name
Amount
DayDue
ModMonthDue




Jan
1




Feb
2




Mar
3




Apr
4




…
…




Nov
11




Dec
0




Looking at the Quarterly Table, you see that a bill that is due in the first month of the quarter has the ModMonth number of 1. This means that once a recurring bill is entered into the table with a ModMonth number, you don't need to know what months it is due. The AddBills Routine will load it every time the CurrentMonth's Mod Result matches.

You can see that only when the Calendar Month number equals the ModDivisor is the ModMonthDue number = 0.

If the EnterNewBills Form asks the User "When is the bill is next due?" Then

ModMonthDue = Month(DateNexDue) Mod ModDivisor

LastDateDue must be a date and will need to be checked separately. Add a Column and compare if LastDateDue < Now Then Delete that Table Row, Shift:=Up

A Word of Warning!
I see Feature Creep coming into play. It can kill a project. Take what you have now and perfect it before adding any new features. As long as you keep modularizing the code like the AddNewBills, AddBillsToForm, and GetBills subs, it won't be hard to add features later, after this is perfected.

Get a notebook and put your new Features ideas in it. Reserve 4 pages for each feature, so you can work in them in the notebook. Take note of the writing style I have been using. Don't look at what I said, look at how I said it.

[mperrah]

This is marking the Every other Friday correctly now:

Sub pd_EoF()

Dim wknm As Date
Dim mywk As Long
Dim x, j As Long

With ufCal

For j = 1 To 42
.Controls("dnum" & j).Font.Bold = False
.Controls("dnum" & j).Font.Size = 9
Next j

For x = 6 To 41 Step 7
If .Controls("dnum" & x).Caption <> "" Then
wknm = .uMonth.Caption & "-" & .Controls("dnum" & x).Caption & "-" & .uYear.Caption
mywk = myWeekNum(wknm)
If wknm Mod 2 = 1 Then
.Controls("dnum" & x).Font.Bold = .ob_EoF.Value
.Controls("dnum" & x).Font.Size = 11
End If
End If
Next x
End With

End Sub

I will prepare a new post for the revised version of this project soon.
Thank you to SamT ans snb for all the help, instruction and truly inspiring ideas.

[mperrah]

14442
Here is the working version.
There are several sheets with formulas in action for testing, they are not necessary but very informative.
-mark

[SamT]

I like the Bill sorting, that's handy!

It has been a pleasure watching you run away with this.

[mperrah]

Thank you Sam. Forgot the print routine -just noticed. I'll post that shortly
Ill add the spinner adjustments too :)

[mperrah]

14445
This adds print function to userform and cleaned up the Payday option buttons. (still updating spinners)
enjoy,
It was a fun and enlightening project.
Thank you for the help!
SamT ans snd.

-mark

[mperrah]

Check this out,
Now the user can scroll up or down unlimited to update the month values. I love vba..


Private Sub sMonth_Change()
'when the up or down arrow is clicked change the Month and update the calendar day numbers and bill dates
With ufCal
Select Case .sMonth.Value
Case Is = 0
.uMonth.Caption = 12
.uYear.Caption = .uYear.Caption - 1
.sMonth.Value = 12
Case Is = 13
.uMonth.Caption = 1
.uYear.Caption = .uYear.Caption + 1
.sMonth.Value = 1
Case Is > 0
.uMonth.Caption = ufCal.sMonth.Value
Case Is < 13
ufCal.uMonth.Caption = ufCal.sMonth.Value
End Select
End With

m_Cal
pd_select

End Sub

[snb]

Read the help files on 'modulo'.

[SamT]

"The Change event occurs when the setting of the Value property changes, regardless of whether the change results from execution of code or a user action in the interface."

User Action changto 0 or 13 generates an additional code change. You may need to change the SpinButton Delay value for slower computers.


Private Sub sMonth1_Change()
'when the up or down arrow is clicked change the Calendar Month and Year Captions

With ufCal
Select Case .sMonth.Value
Case Is = 0
.uYear.Caption = CStr(CLong(.uYear.Caption) - 1)
.sMonth.Value = 12
Case Is = 1: .uMonth.Caption = "Jan"
Case Is = 2: .uMonth.Caption = "Feb"
Case Is = 3" .uMonth.Caption = "Mar"
Case Is = 4: .uMonth.Caption = "Etc"
Case Is = 5: .uMonth.Caption = "Etc"
Case Is = 7: .uMonth.Caption = "Etc"
Case Is = 8: .uMonth.Caption = "Etc"
Case Is = 9: .uMonth.Caption = "Etc"
Case Is = 10: .uMonth.Caption = "Etc"
Case Is = 11: .uMonth.Caption = "Etc"
Case Is = 12: .uMonth.Caption = "Etc"
Case Is = 13
.uYear.Caption = CStr(CLong(.uYear.Caption) + 1)
.sMonth.Value = 1
End Select
End With
End Sub

[mperrah]

Snb: not finding help files on Modulo. Maybe I'm looking on wrong place. Do you have a link I could try ? I am curious

SamT: not sure what to change looking at your offering. are suggesting a different code trigger for the spinner? And what happens if the use is at Jan and clicks down with yours?

[xman2000]

hello mperrah !

i think you BillCalendar works very well with Bluecactus-Calendar.

Bluecactus Calendar have comments like OutlookCalendar
but calendarBluecactus not works!

link to Thread forum by me:
"vbaexpress.com/forum/showthread.php?55438-Calendar-by-BlueCactus-not-works"

if you have this workbook working please share with me!
thanks!