Creating Drop down Calendar in excel

[Sanju!Ekta]

Sponsored Links

Please anyone provide necessary solution. Actually I want to make a Drop down calendar in excel for my personal needs and I don’t know how to do it. I thought of trying different ways by searching over the internet but I did not instead I thought of asking you experts. How to make it? Thank you in advance.

[Dwarner]

To create a Drop down calendar in excel, first you have to create a new user form and then in that add a calendar from tools after that add a command button and code for the command are as follows:

Private Sub cmdClose_Click()
   Unload Me
End Sub

 Private Sub Calender1_Click()
        ActiveCell.Value = Calender1.Value
        Unload Me
End Sub

 
Private Sub UserForm_Initialize()
    If IsDate (ActiveCell.Value) Then
            Calender1.Value = DateValue (ActiveCell.Value)
    Else
            Calender1.Value = Date
    End If

Sub OpenCalender()
      frmCalender.Show
End Sub

[Author]

After adding calendar in the user form you may need an additional option such as shortcut key for that calendar. Below is the command for the shortcut feature for your calendar:

Private Sub WorkBook_Open ()
Application.Onkey "+^{C}", "Module1.OpenCalender"
End Sub

[Jacques25]

If you want to Adding the Calendar to the Shortcut Menu then you have to use vba for it. The code is as follows:

Dim NewControl as CommandBarControl

Add the next line of code below your shortcut key code. It will tell the Excel that the variable is a new item tat to be added to the right-click menu of the cell

      Set NewControl = Application.CommandBars("Cell").Controls.Add

Next line is for some code to describe the new item:

      With NewControl
            .Caption = "Insert Date"
            .OnAction = "Module1.OpenCalendar"
            .BeginGroup = True
      End With

[Vandam]

I would like to assure you that the caption in the text that appears on the menu can be anything you desire. Just keep in mind that OnAction correctly specify your macro name including location. BeingGroup option puts a separator line over the new item on the menu.

Private Sub WorkBook_Open ()
Application.Onkey "+^{C}", "ThisWorkbook.OpenCalender"
Set NewControl = Application.CommandBars ("Cell").Controls.Add
With NewControl
                .caption = "Insert Date"
                .OnAction = "Module1.OpenCalender"
                .BeginGroup = True
End With
End Sub

[Villiers]

If you are interested in popup calendar then copy paste the following code. You must copy the code in the Worksheet module and then Right click on the sheet tab and choose view code at last paste the below code in the sheet module and press Alt-Q to go back to Excel.

Private Sub Calendar1_Click()
    ActiveCell.Value = CDbl(Calendar1.Value)
    ActiveCell.NumberFormat = "mm/dd/yyyy"
    ActiveCell.Select
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
    If Not Application.Intersect(Range("A1:A20"), Target) Is Nothing Then
        Calendar1.Left = Target.Left + Target.Width - Calendar1.Width
        Calendar1.Top = Target.Top + Target.Height
        Calendar1.Visible = True
        ' select Today's date in the Calendar
        Calendar1.Value = Date
    ElseIf Calendar1.Visible Then Calendar1.Visible = False
    End If
End Sub

[Steyn]

To make it convenient for you I have separated the module. You have to assign your button to call Calendar_Main() to run it after that click again on the same button to capture the date.

Private Sub Calendar_Main()
'MAIN CALLING PROGRAM: ADDS/RETRIEVES/DELETES CALENDAR CONTROL;
'THE FUNCTION IS RUN TWICE: ONCE TO LOAD THE CONTROL AND ONCE
'TO CAPTURE THE VALUE AND UNLOAD THE CONTROL; ON THE FIRST CALL
'NO VALUE HAS BEEN ASSIGNED YET (EXIT SUB);
Dim dteCalendarValue As Date
dteCalendarValue = CalendarPopupProgram
If UCase(dteCalendarValue) = "12:00:00 AM" Then Exit Sub
'Optionally run other procedures here - pass the date back to other routines
'instead of just displaying the date captured (as in the following line);
MsgBox Format(dteCalendarValue, "MM/DD/YYYY")
End Sub

[Shreevats]

Also there is another alternative if the above function don’t work for you than you can use the below :

Private Function CalendarPopupProgram() As Date
'CREATE/DELETE CALENDAR ACTIVEX CONTROL
Dim strCalendarName As String
Dim dteCalendarValue As Date
'If calendar exists: obtain the selected date and delete the calendar object
strCalendarName = CalendarGetName
If strCalendarName <> "" Then
dteCalendarValue = ActiveSheet.OLEObjects(strCalendarName).Object.Value
ActiveSheet.Shapes(strCalendarName).Delete
CalendarPopupProgram = DateSerial(Year(dteCalendarValue),
Month(dteCalendarValue), Day(dteCalendarValue))
End If
'If calendar does not exist: create it
If strCalendarName = "" Then Call CalendarAdd
End Function