Как в MS Excel сделать выпадающий календарь при выборе ячейки мышкой

'---------------------------------------------------------------------------------------
' Решение       : Календарь
' Дата и время  : 14 января 2015  01:15
' Автор         : Night Ranger
'                 Яндекс.Деньги - 410012757639478
'                 [email]Exingsteem@yandex.ru[/email]
'                 [url]https://www.cyberforum.ru/vba/[/url]
' Описание      : Этот пример наглядно демонстрирует, как можно использовать календарь
'                 без подключения его к проекту, для этого нужна только форма
'                 совместимость версий любая
'---------------------------------------------------------------------------------------
Const jstart = 5, istart = 5
Const twip = 18, cc = 6
Dim tt(cc, cc) As MSForms.ToggleButton
Dim lb As MSForms.Label
Dim WithEvents fr As MSForms.Frame
Dim WithEvents tb As MSForms.ToggleButton
Dim WithEvents cbMonth As MSForms.ComboBox
Dim WithEvents cbYear As MSForms.ComboBox
Dim WithEvents btn As MSForms.CommandButton
 
Public ThisDate As Date, iNext&, cr As Boolean
 
Private Sub btn_Click()
    cr = False
    ThisDate = Date
    cbMonth.ListIndex = Month(ThisDate) - 1
    cbYear.Text = Year(ThisDate)
    cr = True
    Update
End Sub
 
Private Sub lbUpdate()
    If cr = False Then Exit Sub
    lb.Caption = Format(ThisDate, "mmmm yyyy г")
    If Split(lb.Caption)(0) <> cbMonth.Text Then cbMonth_Click
End Sub
Private Sub Update()
    lbUpdate
    Filling
End Sub
 
Private Sub cbMonth_Click()
    If cr = False Then Exit Sub
    ThisDate = DateSerial(Year(ThisDate), cbMonth.ListIndex + 1, Day(ThisDate))
    Update
End Sub
Private Sub cbYear_Click()
     If cr = False Then Exit Sub
    ThisDate = DateSerial(cbYear.Text, Month(ThisDate), Day(ThisDate))
    Update
End Sub
 
Private Sub UserForm_Initialize()
    maxWidth = twip * (cc + 1) * 2
    Width1 = maxWidth \ 2
    iNext = istart
    jNext = jstart
    ThisDate = Date
    Me.Caption = "Календарь"
    Set fr = Me.Controls.Add("Forms.Frame.1", "fr")
    Set lb = Me.Controls.Add("Forms.Label.1", "lb")
    Set cbMonth = Me.Controls.Add("Forms.ComboBox.1", "cbMonth")
    Set cbYear = Me.Controls.Add("Forms.ComboBox.1", "cbYear")
    Set btn = Me.Controls.Add("Forms.CommandButton.1", "btn")
 
    With lb
        .Move jstart, istart, Width1
        .Font.Size = .Font.Size * 2
        iNext = iNext + .Height + istart
        jNext = jNext + .Width + jstart
    End With
    With cbMonth
        .Move jNext, istart, (Width1 - jstart * 2) \ 2, lb.Height
        For i = 1 To 12
            .AddItem Split(FormatDateTime(DateSerial(0, i, 1), vbLongDate))(1)
        Next
        jNext = jNext + .Width + jstart
    End With
    With cbYear
        .Move jNext, istart, (Width1 - jstart * 2) \ 2, lb.Height
        For i = Year(ThisDate) - 100 To Year(ThisDate) + 100
            .AddItem CStr(i)
        Next
    End With
    With fr
        .Move jstart, iNext, maxWidth, twip * (cc + 1)
        .Enabled = 0
        .SpecialEffect = 0
    End With
    For i = 0 To cc: For j = 0 To cc
        Set tt(j, i) = fr.Controls.Add("Forms.ToggleButton.1", "tt" & i & j)
        With tt(j, i)
            .Move j * twip * 2, i * twip, twip * 2, twip
            .Locked = i = 0
        End With
    Next j, i
    With btn
        .Caption = "Сегодня"
        .Move jstart, iNext + fr.Height + istart, lb.Width, lb.Height
    End With
    btn_Click 'Дата сегодня !
    Filling
    lbUpdate
End Sub
 
Private Sub UserForm_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    On Error Resume Next: Err.Clear
    Set tb = tt((X - jstart) \ twip \ 2, (Y - iNext) \ twip)
    If Err = 0 Then
        With tb
            If .Enabled And .Locked = False Then
                For i = 1 To cc: For j = 0 To cc
                    With tt(j, i)
                        .Value = (.Name = tb.Name)
                        If .Value Then
                            ThisDate = DateSerial(cbYear.Text, cbMonth.ListIndex + 1, .Caption)
                        End If
                    End With
                Next j, i
    End If: End With: End If
End Sub
Sub Filling()
    For j = 0 To cc  'Понедельники вторники даты и тд
        With tt(j, 0)
            .Caption = WeekdayName(j + 1, 1, vbMonday)
            .Font.Bold = 1
        End With
    Next: j = 0
    While Weekday(DateSerial(Year(ThisDate), Month(ThisDate), j)) <> 1
        j = j - 1
    Wend: jj = j
    For i = 1 To cc: For j = 0 To cc
        v = DateSerial(Year(ThisDate), Month(ThisDate), jj) + 1
        With tt(j, i)
            .Caption = Day(v)
            .Enabled = Month(v) = Month(ThisDate)
            .Value = .Enabled And .Caption = Day(ThisDate)
        End With: jj = jj + 1
    Next j, i
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Application.Intersect(Range("Y9:BA9"), Target) Is Nothing Then slancalendar.Show
End Sub

Private Sub TextBox1_MouseDown