Макросы. Выпадающий календарь для excel.

Набор макросов для выпадающего календаря.

Вот так, будет выглядеть выпадающий календарь для Excel, если дочитать до конца.

Для тех, у кого нет времени читать или нет желания разбираться, готовый Excel файл с Лист1, на котором, в любой ячейке, при двойном нажатии на левую кнопку мыши, появляется Календарь можно скачать после перевода на содержание и развитие сайта.

Для тех, кто желает сделать всё сам, следующее повествование.

Создадим Модуль и объявим переменные (кто не знает - обращаемся к Введению.)
    
     Public Str As Long
     Public Stlb As Long


 

Создадим Форму и назовём её Form_SelectDate.

Форма состоит :
- 42 Надписей  Label
- 1-го Поля TextBox
- 1-го Поля ComboBox
- и 1-го счетчика SpinButton

*во все 42 Надписи пишем два события, в соответствии с  именем, а именуем мы их :
Cell_1_1,Cell_1_2..Cell_2_1,Cell_2_2....Cell_6_7.



Private Sub Cell_1_1_Click()
    Set_Дата 1, 1
End Sub
и 
Private Sub Cell_1_1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'Команда - закончить выбор даты и закрыть форму
Set_Дата 1, 1
TB = CStr(DateValue(dt_1))
Unload Me
End Sub
т.е.

 
 

*Поле ComboBox назовем ComboBox_Month и разместим следующий код :

Private Sub ComboBox_Month_Change()
    'Команда - установить дату, выбранную в календаре (смена месяц)
    MyYear = Year(dt_1)
    MyMonth = CInt(ComboBox_Month.ListIndex + 1)
    MyDay = Day(dt_1)
    MyCountDay = Day(DateSerial(MyYear, MyMonth + 1, 1) - 1)
    If MyDay > MyCountDay Then MyDay = MyCountDay
    dt_1 = DateSerial(MyYear, MyMonth, MyDay)
    'Установка TextBox_Year
    TextBox_Year.Value = Format(dt_1, "yyyy")
    'Установка ComboBox_Month и календаря
    Set_M?nth (dt_1)
End Sub
и
*SpinButton назовем SpinButton_Year и разместим следующий код :

Private Sub SpinButton_Year_SpinDown()
    'Команда - установить дату, выбранную в календаре (смена  года -1)
    MyYear = Year(dt_1) - 1
    MyMonth = Month(dt_1)
    MyDay = Day(dt_1)
    MyCountDay = Day(DateSerial(MyYear, MyMonth + 1, 1) - 1)
    If MyDay > MyCountDay Then MyDay = MyCountDay
    dt_1 = DateSerial(MyYear, MyMonth, MyDay)
    'Установка TextBox_Year
    TextBox_Year.Value = Format(dt_1, "yyyy")
    'Установка ComboBox_Month и календаря
    Set_M?nth (dt_1)
End Sub

Private Sub SpinButton_Year_SpinUp()
    'Команда - установить дату, выбранную в календаре (смена  года +1)
    MyYear = Year(dt_1) + 1
    MyMonth = Month(dt_1)
    MyDay = Day(dt_1)
    MyCountDay = Day(DateSerial(MyYear, MyMonth + 1, 1) - 1)
    If MyDay > MyCountDay Then MyDay = MyCountDay
    dt_1 = DateSerial(MyYear, MyMonth, MyDay)
    'Установка TextBox_Year
    TextBox_Year.Value = Format(dt_1, "yyyy")
    'Установка ComboBox_Month и календаря
    Set_M?nth (dt_1)
End Sub
т.е.

 

*в Форме UserForm :

Private Sub UserForm_Initialize()
dt_1 = Now
    'Заполнение списка ComboBox_Month
    ComboBox_Month.AddItem "Январь"
    ComboBox_Month.AddItem "Февраль"
    ComboBox_Month.AddItem "Март"
    ComboBox_Month.AddItem "Апрель"
    ComboBox_Month.AddItem "Май"
    ComboBox_Month.AddItem "Июнь"
    ComboBox_Month.AddItem "Июль"
    ComboBox_Month.AddItem "Август"
    ComboBox_Month.AddItem "Сентябрь"
    ComboBox_Month.AddItem "Октябрь"
    ComboBox_Month.AddItem "Ноябрь"
    ComboBox_Month.AddItem "Декабрь"
'Установка TextBox_Year
TextBox_Year.Value = Format(dt_1, "yyyy")
'Установка ComboBox_Month и календаря
Set_M?nth (dt_1)
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If dt_1 <> 0 And TB <> 0 Then
Cells(Str, Stlb).Value = TB
Else
Cells(Str, Stlb).Value = ""
End If
Cells(Str, Stlb).Activate
End Sub
т.е.

 

*осталось разместить в (General) следующий код :

Private Sub Set_Month(MyDate As Date)
    'Установка ComboBox_Month и календаря
    MyYear = Year(MyDate)
    MyMonth = Month(MyDate)
    MyDay = Day(MyDate)
    ComboBox_Month.ListIndex = MyMonth - 1
    MyWeekDay = Weekday(DateSerial(MyYear, MyMonth, 1), vbMonday)
    MyCountDay = Day(DateSerial(MyYear, MyMonth + 1, 1) - 1)
    l_start = 2 - MyWeekDay
    For i = 1 To 6
        For j = 1 To 7
            If l_start >= 1 And l_start <= MyCountDay Then
                Me.Controls("Cell_" & i & "_" & j).Caption = l_start
            Else
                Me.Controls("Cell_" & i & "_" & j).Caption = ""
            End If
             If l_start = MyDay Then Set_On_Off CInt(i), CInt(j)
    l_start = l_start + 1
    Next j, i
    End Sub
Private Sub Set_Дата(iRow As Integer, jCol As Integer)
    'Команда - утановить дату, выбранную в календаре
    If Me.Controls("Cell_" & iRow & "_" & jCol).Caption = "" Then dt_1 = 0: Exit Sub
    MyYear = Year(dt_1)
    MyMonth = Month(dt_1)
    MyDay = CInt(Me.Controls("Cell_" & iRow & "_" & jCol).Caption)
    dt_1 = DateSerial(MyYear, MyMonth, MyDay)
    'Установка TextBox_Year
    TextBox_Year.Value = Format(dt_1, "yyyy")
    'Установка ComboBox_Month и календаря
    Set_M?nth (dt_1)
End Sub


Private Sub Set_On_Off(iRow As Integer, jCol As Integer)
    If Me.Controls("Cell_" & iRow & "_" & jCol).Caption = "" Then Exit Sub
    ' Очистить все ячейки
    For i = 1 To 6
        For j = 1 To 7
            Me.Controls("Cell_" & i & "_" & j).BackColor = RGB(255, 255, 255)
            Me.Controls("Cell_" & i & "_" & j).BorderColor = RGB(255, 255, 255)
        Next j
    Next i
    ' Выделить текущую ячейку
    Me.Controls("Cell_" & iRow & "_" & jCol).BackColor = RGB(204, 255, 204)
    Me.Controls("Cell_" & iRow & "_" & jCol).BorderColor = RGB(150, 150, 150)
End Sub
т.е.

 

вот и всё, кто дочитал молодец....