Add a Calendar into a cell

F

Farisha

New Member
Joined
Mar 24, 2011
Messages
47
Hi all,

How can I add a Calendar into few cells in my spreadsheet.

I have created a cell to input the dates there. I have seen some user who simply click on the cell and the Calendar pop up and they can select the date whatever they need to instead of typing it.

Will appreciate the help. I am using Excel 2010. Please advise.

Thanks :)
 

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.
Sort by date Sort by votes
.
Here is part of the code :

Code: 
Option Explicit
    Dim ThisDay As Date
    Dim ThisYear, ThisMth As Date
    Dim CreateCal As Boolean
    Dim i As Integer
Private Sub UserForm_Initialize()
    Application.EnableEvents = False
    'starts the form on todays date
    ThisDay = Date
    ThisMth = Format(ThisDay, "mm")
    ThisYear = Format(ThisDay, "yyyy")
    For i = 1 To 12
        CB_Mth.AddItem Format(DateSerial(Year(Date), Month(Date) + i, 0), "mmmm")
    Next
    CB_Mth.ListIndex = Format(Date, "mm") - Format(Date, "mm")
    For i = -20 To 50
        If i = 1 Then CB_Yr.AddItem Format((ThisDay), "yyyy") Else CB_Yr.AddItem _
            Format((DateAdd("yyyy", (i - 1), ThisDay)), "yyyy")
    Next
    CB_Yr.ListIndex = 21
    'Builds the calendar with todays date
    CalendarFrm.Width = CalendarFrm.Width
    CreateCal = True
    Call Build_Calendar
    Application.EnableEvents = True
End Sub
Private Sub CB_Mth_Change()
    'rebuilds the calendar when the month is changed by the user
    Build_Calendar
End Sub
Private Sub CB_Yr_Change()
    'rebuilds the calendar when the year is changed by the user
    Build_Calendar
End Sub
Private Sub Build_Calendar()
    'the routine that actually builds the calendar each time
    If CreateCal = True Then
    CalendarFrm.Caption = " " & CB_Mth.Value & " " & CB_Yr.Value
    'sets the focus for the todays date button
    CommandButton1.SetFocus
    For i = 1 To 42
        If i < Weekday((CB_Mth.Value) & "/1/" & (CB_Yr.Value)) Then
            Controls("D" & (i)).Caption = Format(DateAdd("d", (i - Weekday((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), _
                ((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), "d")
            Controls("D" & (i)).ControlTipText = Format(DateAdd("d", (i - Weekday((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), _
                ((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), "m/d/yy")
        ElseIf i >= Weekday((CB_Mth.Value) & "/1/" & (CB_Yr.Value)) Then
            Controls("D" & (i)).Caption = Format(DateAdd("d", (i - Weekday((CB_Mth.Value) _
                & "/1/" & (CB_Yr.Value))), ((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), "d")
            Controls("D" & (i)).ControlTipText = Format(DateAdd("d", (i - Weekday((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), _
                ((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), "m/d/yy")
        End If
        If Format(DateAdd("d", (i - Weekday((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), _
        ((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), "mmmm") = ((CB_Mth.Value)) Then
            If Controls("D" & (i)).BackColor <> &H80000016 Then Controls("D" & (i)).BackColor = &H80000018  '&H80000010
            Controls("D" & (i)).Font.Bold = True
        If Format(DateAdd("d", (i - Weekday((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), _
            ((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), "m/d/yy") = Format(ThisDay, "m/d/yy") Then Controls("D" & (i)).SetFocus
        Else
            If Controls("D" & (i)).BackColor <> &H80000016 Then Controls("D" & (i)).BackColor = &H8000000F
            Controls("D" & (i)).Font.Bold = False
        End If
    Next
    End If
End Sub
Private Sub D1_Click()
    'this sub and the ones following represent the buttons for days on the form
    'retrieves the current value of the individual controltiptext and
    'places it in the active cell
    ActiveCell.Value = D1.ControlTipText
    Unload Me
    'after unload you can call a different userform to continue data entry
    'uncomment this line and add a userform named UserForm2
    'Userform2.Show
    
End Sub
Private Sub D2_Click()
    ActiveCell.Value = D2.ControlTipText
    Unload Me
    
End Sub
Private Sub D3_Click()
    ActiveCell.Value = D3.ControlTipText
    Unload Me
    
End Sub
Private Sub D4_Click()
    ActiveCell.Value = D4.ControlTipText
    Unload Me
    
End Sub
Private Sub D5_Click()
    ActiveCell.Value = D5.ControlTipText
    Unload Me
    
End Sub
Private Sub D6_Click()
    ActiveCell.Value = D6.ControlTipText
    Unload Me
    
End Sub
Private Sub D7_Click()
    ActiveCell.Value = D7.ControlTipText
    Unload Me
    
End Sub
Private Sub D8_Click()
    ActiveCell.Value = D8.ControlTipText
    Unload Me
    
End Sub
Private Sub D9_Click()
    ActiveCell.Value = D9.ControlTipText
    Unload Me
    
End Sub
Private Sub D10_Click()
    ActiveCell.Value = D10.ControlTipText
    Unload Me
    
End Sub
Private Sub D11_Click()
    ActiveCell.Value = D11.ControlTipText
    Unload Me
    
End Sub
Private Sub D12_Click()
    ActiveCell.Value = D12.ControlTipText
    Unload Me
    
End Sub
Private Sub D13_Click()
    ActiveCell.Value = D13.ControlTipText
    Unload Me
    
End Sub
Private Sub D14_Click()
    ActiveCell.Value = D14.ControlTipText
    Unload Me
    
End Sub
Private Sub D15_Click()
    ActiveCell.Value = D15.ControlTipText
    Unload Me
    
End Sub
Private Sub D16_Click()
    ActiveCell.Value = D16.ControlTipText
    Unload Me
    
End Sub
Private Sub D17_Click()
    ActiveCell.Value = D17.ControlTipText
    Unload Me
    
End Sub
Private Sub D18_Click()
    ActiveCell.Value = D18.ControlTipText
    Unload Me
    
End Sub
Private Sub D19_Click()
    ActiveCell.Value = D19.ControlTipText
    Unload Me
    
End Sub
Private Sub D20_Click()
    ActiveCell.Value = D20.ControlTipText
    Unload Me
    
End Sub
Private Sub D21_Click()
    ActiveCell.Value = D21.ControlTipText
    Unload Me
    
End Sub
Private Sub D22_Click()
    ActiveCell.Value = D22.ControlTipText
    Unload Me
    
End Sub
Private Sub D23_Click()
    ActiveCell.Value = D23.ControlTipText
    Unload Me
    
End Sub
Private Sub D24_Click()
    ActiveCell.Value = D24.ControlTipText
    Unload Me
    
End Sub
Private Sub D25_Click()
    ActiveCell.Value = D25.ControlTipText
    Unload Me
    
End Sub
Private Sub D26_Click()
    ActiveCell.Value = D26.ControlTipText
    Unload Me
    
End Sub
Private Sub D27_Click()
    ActiveCell.Value = D27.ControlTipText
    Unload Me
    
End Sub
Private Sub D28_Click()
    ActiveCell.Value = D28.ControlTipText
    Unload Me
    
End Sub
Private Sub D29_Click()
    ActiveCell.Value = D29.ControlTipText
    Unload Me
    
End Sub
Private Sub D30_Click()
    ActiveCell.Value = D30.ControlTipText
    Unload Me
    
End Sub
Private Sub D31_Click()
    ActiveCell.Value = D31.ControlTipText
    Unload Me
    
End Sub
Private Sub D32_Click()
    ActiveCell.Value = D32.ControlTipText
    Unload Me
    
End Sub
Private Sub D33_Click()
    ActiveCell.Value = D33.ControlTipText
    Unload Me
    
End Sub
Private Sub D34_Click()
    ActiveCell.Value = D34.ControlTipText
    Unload Me
    
End Sub
Private Sub D35_Click()
    ActiveCell.Value = D35.ControlTipText
    Unload Me
    
End Sub
Private Sub D36_Click()
    ActiveCell.Value = D36.ControlTipText
    Unload Me
    
End Sub
Private Sub D37_Click()
    ActiveCell.Value = D37.ControlTipText
    Unload Me
    
End Sub
Private Sub D38_Click()
    ActiveCell.Value = D38.ControlTipText
    Unload Me
    
End Sub
Private Sub D39_Click()
    ActiveCell.Value = D39.ControlTipText
    Unload Me
    
End Sub
Private Sub D40_Click()
    ActiveCell.Value = D40.ControlTipText
    Unload Me
    
End Sub
Private Sub D41_Click()
    ActiveCell.Value = D41.ControlTipText
    Unload Me
    
End Sub
Private Sub D42_Click()
    ActiveCell.Value = D42.ControlTipText
    Unload Me
    
End Sub

Download workbook : https://www.amazon.com/clouddrive/share/XHRXgGrO1PRttTIqHvH8uCdNCnsw2UTD2p9QtuyYt95
 
Upvote 0
You must log in or register to reply here.

Similar threads

0
  • Question Question
Pop-up Calendar
Replies
8
Views
255
edge37
edge37
R
  • Question Question
Leave Database Time Tracking to equal full day after 8 hours
Replies
6
Views
324
NoSparks
N
L
  • Question Question
Code shuts down excel
Replies
3
Views
362
Peter_SSs
Peter_SSs
H
  • Question Question
Creating a data entry form to add a new row with merged cells
Replies
0
Views
242
horizonblue
H
S
  • Question Question
Paste Shape under matching "Calendar" date
Replies
0
Views
271
Scoti
S

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top