none
How to Add a Date Picker to UserForm RRS feed

  • Question

  • Hi 

    I am looking for a control to add to userForm to enable user to pick the date.I a good one at this address

     http://stackoverflow.com/questions/12012206/formatting-mm-dd-yyyy-dates-in-textbox-in-vba

    from Siddharth Rout which is perfect but it generate invisible sheets which is not nessaccary for my application I tried to stop creating sheets but i couldnt figure it out.

    Here is the part of his code which is generating sheets

    Private Sub UserForm_Initialize()
     '~~> Create a temp sheet for `GenerateCal` to work upon
    Set ws = Sheets.Add
       ws.Visible = xlSheetVeryHidden
       GenerateCal Format(Date, "mm/yyyy")
    End Sub
    
    '~~> Generate Sheet
    '~~> Code based on http://support.microsoft.com/kb/150774
    Private Sub GenerateCal(dt As String)
        With ws
            .Cells.Clear
            StartDay = DateValue(dt)
            ' Check if valid date but not the first of the month
            ' -- if so, reset StartDay to first day of month.
            If Day(StartDay) <> 1 Then
                StartDay = DateValue(Month(StartDay) & "/1/" & _
                    Year(StartDay))
            End If
            ' Prepare cell for Month and Year as fully spelled out.
            .Range("a1").NumberFormat = "mmmm yyyy"
            ' Center the Month and Year label across a1:g1 with appropriate
            ' size, height and bolding.
            With .Range("a1:g1")
                .HorizontalAlignment = xlCenterAcrossSelection
                .VerticalAlignment = xlCenter
                .Font.Size = 18
                .Font.Bold = True
                .RowHeight = 35
            End With
            ' Prepare a2:g2 for day of week labels with centering, size,
            ' height and bolding.
            With .Range("a2:g2")
                .ColumnWidth = 11
                .VerticalAlignment = xlCenter
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Orientation = xlHorizontal
                .Font.Size = 12
                .Font.Bold = True
                .RowHeight = 20
            End With
            ' Put days of week in a2:g2.
            .Range("a2") = "Sunday"
            .Range("b2") = "Monday"
            .Range("c2") = "Tuesday"
            .Range("d2") = "Wednesday"
            .Range("e2") = "Thursday"
            .Range("f2") = "Friday"
            .Range("g2") = "Saturday"
            ' Prepare a3:g7 for dates with left/top alignment, size, height
            ' and bolding.
            With .Range("a3:g8")
                .HorizontalAlignment = xlRight
                .VerticalAlignment = xlTop
                .Font.Size = 18
                .Font.Bold = True
                .RowHeight = 21
            End With
            ' Put inputted month and year fully spelling out into "a1".
            .Range("a1").Value = Application.Text(dt, "mmmm yyyy")
            ' Set variable and get which day of the week the month starts.
            DayofWeek = Weekday(StartDay)
            ' Set variables to identify the year and month as separate
            ' variables.
            CurYear = Year(StartDay)
            CurMonth = Month(StartDay)
            ' Set variable and calculate the first day of the next month.
            FinalDay = DateSerial(CurYear, CurMonth + 1, 1)
            ' Place a "1" in cell position of the first day of the chosen
            ' month based on DayofWeek.
            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
            ' Loop through .Range a3:g8 incrementing each cell after the "1"
            ' cell.
            For Each cell In .Range("a3:g8")
                RowCell = cell.Row
                ColCell = cell.Column
                ' Do if "1" is in first column.
                If cell.Column = 1 And cell.Row = 3 Then
                ' Do if current cell is not in 1st column.
                ElseIf cell.Column <> 1 Then
                    If cell.Offset(0, -1).Value >= 1 Then
                        cell.Value = cell.Offset(0, -1).Value + 1
                        ' Stop when the last day of the month has been
                        ' entered.
                        If cell.Value > (FinalDay - StartDay) Then
                            cell.Value = ""
                            ' Exit loop when calendar has correct number of
                            ' days shown.
                            Exit For
                        End If
                    End If
                ' Do only if current cell is not in Row 3 and is in Column 1.
                ElseIf cell.Row > 3 And cell.Column = 1 Then
                    cell.Value = cell.Offset(-1, 6).Value + 1
                    ' Stop when the last day of the month has been entered.
                    If cell.Value > (FinalDay - StartDay) Then
                        cell.Value = ""
                        ' Exit loop when calendar has correct number of days
                        ' shown.
                        Exit For
                    End If
                End If
            Next
        
            ' Create Entry cells, format them centered, wrap text, and border
            ' around days.
            For x = 0 To 5
                .Range("A4").Offset(x * 2, 0).EntireRow.Insert
                With .Range("A4:G4").Offset(x * 2, 0)
                    .RowHeight = 65
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlTop
                    .WrapText = True
                    .Font.Size = 10
                    .Font.Bold = False
                    ' Unlock these cells to be able to enter text later after
                    ' sheet is protected.
                    .Locked = False
                End With
                ' Put border around the block of dates.
                With .Range("A3").Offset(x * 2, 0).Resize(2, _
                7).Borders(xlLeft)
                    .Weight = xlThick
                    .ColorIndex = xlAutomatic
                End With
        
                With .Range("A3").Offset(x * 2, 0).Resize(2, _
                7).Borders(xlRight)
                    .Weight = xlThick
                    .ColorIndex = xlAutomatic
                End With
                .Range("A3").Offset(x * 2, 0).Resize(2, 7).BorderAround _
                   Weight:=xlThick, ColorIndex:=xlAutomatic
            Next
            If .Range("A13").Value = "" Then .Range("A13").Offset(0, 0) _
               .Resize(2, 8).EntireRow.Delete
        
            ' Resize window to show all of calendar (may have to be adjusted
            ' Allow screen to redraw with calendar showing.
            Application.ScreenUpdating = True
            
            '~~> Update Dates on command button
            CommandButton1.Caption = .Range("A3").Text
            CommandButton2.Caption = .Range("B3").Text
            CommandButton3.Caption = .Range("C3").Text
            CommandButton4.Caption = .Range("D3").Text
            CommandButton5.Caption = .Range("E3").Text
            CommandButton6.Caption = .Range("F3").Text
            CommandButton7.Caption = .Range("G3").Text
            
            CommandButton8.Caption = .Range("A5").Text
            CommandButton9.Caption = .Range("B5").Text
            CommandButton10.Caption = .Range("C5").Text
            CommandButton11.Caption = .Range("D5").Text
            CommandButton12.Caption = .Range("E5").Text
            CommandButton13.Caption = .Range("F5").Text
            CommandButton14.Caption = .Range("G5").Text
            
            CommandButton15.Caption = .Range("A7").Text
            CommandButton16.Caption = .Range("B7").Text
            CommandButton17.Caption = .Range("C7").Text
            CommandButton18.Caption = .Range("D7").Text
            CommandButton19.Caption = .Range("E7").Text
            CommandButton20.Caption = .Range("F7").Text
            CommandButton21.Caption = .Range("G7").Text
            
            CommandButton22.Caption = .Range("A9").Text
            CommandButton23.Caption = .Range("B9").Text
            CommandButton24.Caption = .Range("C9").Text
            CommandButton25.Caption = .Range("D9").Text
            CommandButton26.Caption = .Range("E9").Text
            CommandButton27.Caption = .Range("F9").Text
            CommandButton28.Caption = .Range("G9").Text
            
            CommandButton29.Caption = .Range("A11").Text
            CommandButton30.Caption = .Range("B11").Text
            CommandButton31.Caption = .Range("C11").Text
            CommandButton32.Caption = .Range("D11").Text
            CommandButton33.Caption = .Range("E11").Text
            CommandButton34.Caption = .Range("F11").Text
            CommandButton35.Caption = .Range("G11").Text
            
            CommandButton46.Caption = .Range("A13").Text
            CommandButton47.Caption = .Range("B13").Text
            CommandButton48.Caption = .Range("C13").Text
            CommandButton49.Caption = .Range("D13").Text
            CommandButton50.Caption = .Range("E13").Text
            CommandButton51.Caption = .Range("F13").Text
            CommandButton52.Caption = .Range("G13").Text
        End With
    End Sub
    

    Can you please let me know how I can properly modified the Siddharth Rout code or find another 

    Friday, November 16, 2012 2:37 AM

All replies

  • Are you ever use common controls 2 (mscomct2.ocx)?

    You can use this simple code to set date to cell:

    Private Sub UserForm_Initialize()
    'two controls
    MonthView1.value = Now
    DTPicker1.value = Now
    End Sub
    
    Private Sub DTPicker1_Change()
    ActiveCell.value = Format(DTPicker1.value, "Short Date")
    End Sub
    
    Private Sub MonthView1_DateClick(ByVal DateClicked As Date)
    ActiveCell.value = MonthView1.value
    End Sub


    Oskar Shon, Office System MVP

    Press if Helpful; Answer when a problem solved

    Friday, November 16, 2012 1:37 PM
    Answerer
  • Thansk VBATools  but I am using MS Office 2010 64 bit and this control is not there any more!
    • Edited by Behseini Friday, November 16, 2012 4:38 PM
    Friday, November 16, 2012 4:26 PM
  • Try to download and add and register new control using this command from cmd:

    regsvr32 c:\windows\syswow64\mscomct2.ocx


    Oskar Shon, Office System MVP

    Press if Helpful; Answer when a problem solved

    Saturday, November 17, 2012 10:10 AM
    Answerer
  • The best tutorial found on the Internet. Click on or copy the link and you will solve your problem.

    https://www.youtube.com/watch?v=JtRQC5qnrHQ


    • Edited by Zecapira Thursday, September 19, 2019 3:59 PM
    Thursday, September 19, 2019 3:53 PM