Создать календарь на Excel

Привет, прошу помочь мне в запутанной программе... Юзал поиск и нашел "Календарь на 1 месяц"
Sub q()
год = Range("E3").Value
номер_месяца = Range("E4").Value
Select Case номер_месяца
Case 1, 3, 5, 7, 8, 10, 12
число_дней_в_месяце = 31
Case 2
If год Mod 4 = 0 Then число_дней_в_месяце = 29 Else число_дней_в_месяце = 28
Case Else
число_дней_в_месяце = 30
End Select
месяц_и_год = MonthName(номер_месяца) + Str(год) + " года"
Range("A6").Value = месяц_и_год
Range("A8").Value = "Пн"
Range("A9").Value = "Вт"
Range("A10").Value = "Ср"
Range("A11").Value = "Чт"
Range("A12").Value = "Пт"
Range("A13").Value = "Сб"
Range("A14").Value = "Вс"
дата1 = "1" + "." + Str(номер_месяца) + "." + Str(год)
номер_дня_недели_1_числа_месяца = Weekday(дата1, 1) - 1
Range("B7").Activate
For i = 1 To номер_дня_недели_1_числа_месяца - 1
ActiveCell.Cells(2).Activate
Next i
количество_дней_в_1_столбце = 7 - номер_дня_недели_1_числа_месяца + 1
For i = 1 To количество_дней_в_1_столбце
ActiveCell.Cells(2).Activate
ActiveCell.Value = i
Next i
количество_полных_столбцов = (число_дней_в_месяце - количество_дней_в_1_столбце) / 7
записываемое_число = количество_дней_в_1_столбце + 1
For g = 1 To количество_полных_столбцов
For i = 1 To 7
ActiveCell.Cells(0).Activate
Next i
ActiveCell.Cells(1, 2).Activate
For i = 1 To 7
ActiveCell.Cells(2).Activate
ActiveCell.Value = записываемое_число
записываемое_число = записываемое_число + 1
Next i
Next g
If записываемое_число <= число_дней_в_месяце Then ActiveCell.Cells(-6, 2).Activate
For i = 1 To число_дней_в_месяце - записываемое_число + 1
ActiveCell.Cells(2).Activate
ActiveCell.Value = записываемое_число
записываемое_число = записываемое_число + 1
Next i
End Sub
Sub f()
Range("B6:G14").Clear
Range("E3:E4").Clear
Range("A6").Clear
Range("E3").Activate
End Sub
Она выполняет всё круто... Но мне нужно, чтобы этот же самый код выполнялся через UserForm, ту бишь при выполнении макроса календарь открывался в отдельном окне... Прошу помощи...
2 ответа

Такой календарь нужен? http://excelvba.ru/programmes/PrintContractsИли такой? http://excelvba.ru/tools/DatePicker


Или такой? http://excelvba.ru/tools/DatePicker
Такой... Спс, если кому нужно, вот исходник этой проги
Public oDatePickerManager As samradDATE
Public fUseFading As Boolean
Public fIsWinNT As Boolean
Public sPathToIcon As String

Public Sub DisplayCalendar()
 Dim Переменная058 As Boolean
 Dim Переменная0173 As Date
 On Error Resume Next
 oDatePickerManager.EnsureCalendar
 oDatePickerManager.Calendar.LoadDate oDatePickerManager.LoadThisDate, True
 Set oDatePickerManager.Calendar.CellToChange = oDatePickerManager.SelectedCell
 Переменная0173 = oDatePickerManager.SelectedCell.Formula
 If Переменная0173 <> "12:00:00AM" Or oDatePickerManager.SelectedCell.Formula = "" Then
 oDatePickerManager.Calendar.ClearInfoText
 Else
 oDatePickerManager.Calendar.SetInfoText "Choosing a day will replace the current cells formula"
 End If
 If oDatePickerManager.Calendar.Top < 0 Then oDatePickerManager.Calendar.Top = 0
 If oDatePickerManager.Calendar.Left < 0 Then oDatePickerManager.Calendar.Left = 0
 oDatePickerManager.Calendar.Width = 147
 AdjustWindowStyle GetHwnd(oDatePickerManager.Calendar, True)
 oDatePickerManager.Calendar.Show
 FadeMenu GetHwnd(oDatePickerManager.Calendar, False)
End Sub

Public Sub AfterUserPicksADay()
 oDatePickerManager.LoadThisDate = oDatePickerManager.SelectedCell.Value
End Sub