Excel VBA - calendar date pick up: problem with code

MEGSS

New Member
Joined
Feb 15, 2019
Messages
3
Hi guys,

I am new to VBA and I need some help please.

I created a calendar in vba using different sources that I found online.

It I supposed to pop up in two cells on my Excel spreadsheet when I Click on those cells, and it does.
The problem is that when I click on any date, it will not fill the selected date in the Excel worksheet cell. So I guess the code for this specific action is wrong.

Here is what I have done so far: I created a form with multiple labels (contain the days of the week) and 2 image controls, one to contain the left icon to scroll previous months and one to scroll next month.

This s the code on the form:

Code:
Option Explicit
Private curMonth As Date

Private Function FirstCalSun(ref_date As Date) As Date
  
    FirstCalSun = DateSerial(Year(ref_date), _
                  Month(ref_date), 1) - (Weekday(ref_date) - 1)
End Function
Private Sub Build_Calendar(first_sunday As Date)
    Dim lDate As MSForms.Label
    Dim i As Integer, a_date As Date
    For i = 1 To 42
        a_date = first_sunday + (i - 1)
        Set lDate = Me.Controls("Label_" & Format(i, "00"))
        lDate.Caption = Day(a_date)
        If Month(a_date) <> Month(curMonth) Then
            lDate.ForeColor = &H80000011
        Else
            If Weekday(a_date) = 1 Then
                lDate.ForeColor = &HC0&
            Else
                lDate.ForeColor = &H80000012
            End If
        End If
    Next
End Sub
Private Sub select_label(msForm_C As MSForms.Control)
    Dim i As Integer, sel_date As Date
    i = Split(msForm_C.Name, "_")(1) - 1
    sel_date = FirstCalSun(curMonth) + i
    
    MsgBox sel_date
End Sub
Sub ExplicitSelectCell()
Sheets("Sheet1").Activate
ActiveSheet.Range("E2", "F2").Select
End Sub
Private Sub MonthView1_DateClick(ByVal DateClicked As Date)
On Error Resume Next
ActiveCell.Value = DateClicked
  
End Sub
Private Sub CommandButton1_Click()
Unload Me
End Sub
Private Sub Image_Left_Click()
    If Month(curMonth) = 1 Then
        curMonth = DateSerial(Year(curMonth) - 1, 12, 1)
    Else
        curMonth = DateSerial(Year(curMonth), Month(curMonth) - 1, 1)
    End If
    With Me
        .Label_MthYr.Caption = Format(curMonth, "mmmm, yyyy")
        Build_Calendar FirstCalSun(curMonth)
    End With
End Sub
Private Sub Image_Right_Click()
 If Month(curMonth) = 12 Then
        curMonth = DateSerial(Year(curMonth) + 1, 1, 1)
    Else
        curMonth = DateSerial(Year(curMonth), Month(curMonth) + 1, 1)
    End If
    With Me
        .Label_MthYr.Caption = Format(curMonth, "mmmm, yyyy")
        Build_Calendar FirstCalSun(curMonth)
    End With
End Sub
Private Sub Image_Left_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, _
                                 ByVal X As Single, ByVal Y As Single)
    Me.Image_Left.BorderStyle = fmBorderStyleSingle
End Sub
Private Sub Image_Left_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
                               ByVal X As Single, ByVal Y As Single)
    Me.Image_Left.BorderStyle = fmBorderStyleNone
End Sub
Private Sub Image_Right_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, _
                                 ByVal X As Single, ByVal Y As Single)
    Me.Image_Right.BorderStyle = fmBorderStyleSingle
End Sub
Private Sub Image_Right_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
                               ByVal X As Single, ByVal Y As Single)
    Me.Image_Right.BorderStyle = fmBorderStyleNone
End Sub
Private Sub Label_01_Click()
    select_label Me.Label_01
End Sub
Private Sub Label_02_Click()
    select_label Me.Label_02
End Sub
Private Sub Label_03_Click()
    select_label Me.Label_03
End Sub
Private Sub Label_04_Click()
    select_label Me.Label_04
End Sub
Private Sub Label_05_Click()
    select_label Me.Label_05
End Sub
Private Sub Label_06_Click()
    select_label Me.Label_06
End Sub
Private Sub Label_07_Click()
    select_label Me.Label_07
End Sub
Private Sub Label_08_Click()
    select_label Me.Label_08
End Sub
Private Sub Label_09_Click()
    select_label Me.Label_09
End Sub
Private Sub Label_10_Click()
    select_label Me.Label_10
End Sub
Private Sub Label_11_Click()
    select_label Me.Label_11
End Sub
Private Sub Label_12_Click()
    select_label Me.Label_12
End Sub
Private Sub Label_13_Click()
    select_label Me.Label_13
End Sub
Private Sub Label_14_Click()
    select_label Me.Label_14
End Sub
Private Sub Label_15_Click()
    select_label Me.Label_15
End Sub
Private Sub Label_16_Click()
    select_label Me.Label_16
End Sub
Private Sub Label_17_Click()
    select_label Me.Label_17
End Sub
Private Sub Label_18_Click()
    select_label Me.Label_18
End Sub
Private Sub Label_19_Click()
    select_label Me.Label_19
End Sub
Private Sub Label_20_Click()
    select_label Me.Label_20
End Sub
Private Sub Label_21_Click()
    select_label Me.Label_21
End Sub
Private Sub Label_22_Click()
    select_label Me.Label_22
End Sub
Private Sub Label_23_Click()
    select_label Me.Label_23
End Sub
Private Sub Label_24_Click()
    select_label Me.Label_24
End Sub
Private Sub Label_25_Click()
    select_label Me.Label_25
End Sub
Private Sub Label_26_Click()
    select_label Me.Label_26
End Sub
Private Sub Label_27_Click()
    select_label Me.Label_27
End Sub
Private Sub Label_28_Click()
    select_label Me.Label_28
End Sub
Private Sub Label_29_Click()
    select_label Me.Label_29
End Sub
Private Sub Label_30_Click()
    select_label Me.Label_30
End Sub
Private Sub Label_31_Click()
    select_label Me.Label_31
End Sub
Private Sub Label_32_Click()
    select_label Me.Label_32
End Sub
Private Sub Label_33_Click()
    select_label Me.Label_33
End Sub
Private Sub Label_34_Click()
    select_label Me.Label_34
End Sub
Private Sub Label_35_Click()
    select_label Me.Label_35
End Sub
Private Sub Label_36_Click()
    select_label Me.Label_36
End Sub
Private Sub Label_37_Click()
    select_label Me.Label_37
End Sub
Private Sub Label_38_Click()
    select_label Me.Label_38
End Sub
Private Sub Label_39_Click()
    select_label Me.Label_39
End Sub
Private Sub Label_40_Click()
    select_label Me.Label_40
End Sub
Private Sub Label_41_Click()
    select_label Me.Label_41
End Sub
Private Sub Label_42_Click()
    select_label Me.Label_42
End Sub
Private Sub Label_01_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, _
                               ByVal X As Single, ByVal Y As Single)
    Me.Label_01.BorderStyle = fmBorderStyleSingle
End Sub
Private Sub Label_01_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
                               ByVal X As Single, ByVal Y As Single)
    Me.Label_01.BackColor = &H8000000B
End Sub
Private Sub Label_01_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
                             ByVal X As Single, ByVal Y As Single)
    Me.Label_01.BorderStyle = fmBorderStyleNone
End Sub

Private Sub UserForm_Initialize()
    With Me
        curMonth = DateSerial(Year(Date), Month(Date), 1)
        .Label_MthYr = Format(curMonth, "mmmm, yyyy")
        Build_Calendar FirstCalSun(curMonth)
    End With
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
                               ByVal X As Single, ByVal Y As Single)
    With Me
        Dim ctl As MSForms.Control, lb As MSForms.Label
        For Each ctl In .Controls
            If ctl.Tag = "dts" Then
                Set lb = ctl: lb.BackColor = &H80000005
            End If
        Next
    End With
End Sub

This is the code that is wrong:
Code:
Private Sub MonthView1_DateClick(ByVal DateClicked As Date)
On Error Resume Next

ActiveCell.Value = DateClicked
  
End Sub

And this is the code to show my calendar in cells E2 and F2 of my worksheet only.
Code:
Private Sub worksheet_selectionchange(ByVal target As Range)
If Not Application.Intersect(Range("E2"), target) Is Nothing Then
MyCalendar.Show
End If
If Not Application.Intersect(Range("F2"), target) Is Nothing Then
MyCalendar.Show
End If
End Sub

Thank you!
 

Some videos you may like

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)

Jeffrey Mahoney

Well-known Member
Joined
May 31, 2015
Messages
1,830
Office Version
  1. 365
Platform
  1. Windows
My first thought on this is that the SUB MonthView1_DateClick doesn't get called from anywhere. You should create a breakpoint in that SUB and debug the code to see if it gets called at all; and if it does, find out if DateClicked has any value.

I use a couple different calendars similar to this. I would need the Form to test it fully.

Jeff
 

MEGSS

New Member
Joined
Feb 15, 2019
Messages
3
Thank you, Jeff.
I did the debug and yes, the code doesn't get called at all and I do not know how to do it.
If it helps I could post the link where I got the form and the code from.
 

MEGSS

New Member
Joined
Feb 15, 2019
Messages
3
Everything works fine, the calendar only pops up when I click on these two cells only. So, when I click on E2, the calendar pops up, I select a date, then a message box with the selected date pops up, I click ok to close it, then I close the calendar, but the date I clicked on will not be inserted in my E2 cell.

I guess I need a code in the select_label procedure below which will make the date I click on in the calendar and pops up in the MsgBox fill my excel E2 or F2 cells.

<code> Private Sub select_label(msForm_C As MSForms.Control)
'/* Capture the selected date */
Dim i As Integer, sel_date As Date
i = Split(msForm_C.Name, "_")(1) - 1
sel_date = FirstCalSun(curMonth) + i

'/* Transfer the date where you want it to go */
MsgBox sel_date

End Sub</code>
 

Jeffrey Mahoney

Well-known Member
Joined
May 31, 2015
Messages
1,830
Office Version
  1. 365
Platform
  1. Windows
There must be a control on the form that selects the date and continues; like an OK button or something. I had an OK button, but I also tested if the end user double clicked a date. Either one of those would call your SUB MonthView1_DateClick.

Jeff
 

Watch MrExcel Video

Forum statistics

Threads
1,122,819
Messages
5,598,289
Members
414,223
Latest member
Accountant2B

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
Top