Consulting

Page 1 of 3 1 2 3 LastLast
Results 1 to 20 of 59

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

  1. #1
    VBAX Expert mperrah's Avatar
    Joined
    Mar 2005
    Posts
    738
    Location

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

    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

  2. #2
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,272
    Location
    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
    I expect the student to do their homework and find all the errrors I leeve in.


    Please take the time to read the Forum FAQ

  3. #3
    VBAX Expert mperrah's Avatar
    Joined
    Mar 2005
    Posts
    738
    Location
    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..
    Counting Cells userform Calendar SamT.xlsm

  4. #4
    VBAX Expert mperrah's Avatar
    Joined
    Mar 2005
    Posts
    738
    Location
    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

  5. #5
    VBAX Expert mperrah's Avatar
    Joined
    Mar 2005
    Posts
    738
    Location
    Thank you SamT
    You are phenomenal!

  6. #6
    VBAX Expert mperrah's Avatar
    Joined
    Mar 2005
    Posts
    738
    Location
    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

  7. #7
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,272
    Location
    Try this format
    "d-mmm-yy"
    I expect the student to do their homework and find all the errrors I leeve in.


    Please take the time to read the Forum FAQ

  8. #8
    VBAX Expert mperrah's Avatar
    Joined
    Mar 2005
    Posts
    738
    Location
    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)

  9. #9
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,272
    Location
    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
    I expect the student to do their homework and find all the errrors I leeve in.


    Please take the time to read the Forum FAQ

  10. #10
    Knowledge Base Approver VBAX Guru
    Joined
    Apr 2012
    Posts
    4,920
    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

  11. #11
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,272
    Location
    @ 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.
    I expect the student to do their homework and find all the errrors I leeve in.


    Please take the time to read the Forum FAQ

  12. #12
    Knowledge Base Approver VBAX Guru
    Joined
    Apr 2012
    Posts
    4,920
    I rewrote the userform code.
    Attached Files Attached Files

  13. #13
    VBAX Expert mperrah's Avatar
    Joined
    Mar 2005
    Posts
    738
    Location
    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

  14. #14
    VBAX Expert mperrah's Avatar
    Joined
    Mar 2005
    Posts
    738
    Location

    User form Calendar for bill scheduling

    Calendar SamT snb.xlsm
    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.

  15. #15
    Knowledge Base Approver VBAX Guru
    Joined
    Apr 2012
    Posts
    4,920
    A new version
    Attached Files Attached Files
    Last edited by snb; 09-13-2015 at 12:07 PM.

  16. #16
    VBAX Expert mperrah's Avatar
    Joined
    Mar 2005
    Posts
    738
    Location
    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

  17. #17
    VBAX Expert mperrah's Avatar
    Joined
    Mar 2005
    Posts
    738
    Location
    __frm Calendar snb_mod02.xlsm
    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.
    Last edited by mperrah; 09-14-2015 at 12:50 PM.

  18. #18
    VBAX Expert mperrah's Avatar
    Joined
    Mar 2005
    Posts
    738
    Location
    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

  19. #19
    Knowledge Base Approver VBAX Guru
    Joined
    Apr 2012
    Posts
    4,920
    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
    Attached Files Attached Files
    Last edited by snb; 09-14-2015 at 02:20 PM.

  20. #20
    VBAX Expert mperrah's Avatar
    Joined
    Mar 2005
    Posts
    738
    Location
    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.__frm Calendar snb_mod03.xlsm

    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

Posting Permissions

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