Vba excel userform календарь - Word и Excel - помощь в работе с программами

Элемент управления пользовательской формы DTPicker (поле с календарем), предназначенный для выбора и ввода даты. Примеры кода VBA Excel с DTPicker.

UserForm.DTPicker – это элемент управления пользовательской формы, представляющий из себя отформатированное текстовое поле с раскрывающимся календарем, клик по выбранной дате в котором записывает ее в текстовое поле.

При вызове календаря пользовательская форма теряет фокус – это видно на изображении. При редактировании даты непосредственно в текстовом поле DTPicker, формат поля позволяет изменять элементы даты (день, месяц, год) по отдельности.

Чтобы перемещаться между элементами даты, необходимо, или выбирать элемент мышью, или нажимать любой знак разделителя («.», «,» или «/») на клавиатуре. А клик по знаку «+» или «-», соответственно, увеличит или уменьшит значение элемента даты на единицу.

Если в элемент «год» ввести однозначное число или двузначное число, не превышающее двузначный остаток текущего года, через пару секунд автоматически добавятся первые две цифры текущего столетия (20). Если вводимое двузначное число превысит двузначный остаток текущего года, автоматически добавятся первые две цифры прошлого столетия (19).

DTPicker – это сокращение от слова DateTimePicker, не являющегося в VBA Excel ключевым словом, как и DatePicker.

Добавление DTPicker на Toolbox

Изначально на панели инструментов Toolbox нет ссылки на элемент управления DTPicker, поэтому ее нужно добавить самостоятельно.

Чтобы добавить DTPicker на панель инструментов Toolbox, кликните по ней правой кнопкой мыши и выберите из контекстного меню ссылку «Additional Controls…»:

В открывшемся окне «Additional Controls» из списка дополнительных элементов управления выберите строку «Microsoft Date and Time Picker Control»:

Нажмите кнопку «OK» и значок элемента управления DTPicker появится на панели инструментов Toolbox:

Свойства поля с календарем

Свойство	Описание
CalendarBackColor	Заливка (фон) календаря без заголовка.
CalendarForeColor	Цвет шрифта чисел выбранного в календаре месяца.
CalendarTitleBackColor	Заливка заголовка календаря и фон выбранной даты.
CalendarTitleForeColor	Цвет шрифта заголовка (месяц и год) и выбранного в календаре числа.
CalendarTrailingForeColor	Цвет шрифта чисел предыдущего и следующего месяца.
CheckBox	В значении True отображает встроенный в DTPicker элемент управления CheckBox. По умолчанию – False.
ControlTipText	Текст всплывающей подсказки при наведении курсора на DTPicker.
CustomFormat	Пользовательский формат даты и времени. Работает, когда свойству Format присвоено значение dtpCustom (3).
Day (Month, Year)	Задает или возвращает день (месяц, год).
DayOfWeek	Задает или возвращает день недели от 1 до 7, отсчет начинается с воскресенья.
Enabled	Возможность раскрытия календаря, ввода и редактирования даты/времени. True – все перечисленные опции включены, False – выключены (элемент управления становится серым).
Font	Шрифт отображаемого значения в отформатированном поле элемента управления.
Format	Формат отображаемого значения в поле элемента управления DTPicker, может принимать следующие значения: dtpCustom (3), dtpLongDate (0), dtpShortDate (1) (по умолчанию) и dtpTime (2).
Height	Высота элемента управления DTPicker с нераскрытым календарем.
Hour (Minute, Second)	Задает или возвращает часы (минуты, секунды).
Left	Расстояние от левого края внутренней границы пользовательской формы до левого края элемента управления.
MaxDate	Максимальное значение даты, которое может быть выбрано в элементе управления (по умолчанию – 31.12.9999).
MinDate	Минимальное значение даты, которое может быть выбрано в элементе управления (по умолчанию – 01.01.1601).
TabIndex	Определяет позицию элемента управления в очереди на получение фокуса при табуляции, вызываемой нажатием клавиш «Tab», «Enter». Отсчет начинается с нуля.
Top	Расстояние от верхнего края внутренней границы пользовательской формы до верхнего края элемента управления.
UpDown	Отображает счетчик вместо раскрывающегося календаря. True – отображается SpinButton, False – отображается календарь (по умолчанию).
Value	Задает или возвращает значение (дата и/или время) элемента управления.
Visible	Видимость поля с календарем. True – DTPicker отображается на пользовательской форме, False – DTPicker скрыт.
Width	Ширина элемента управления DTPicker с нераскрытым календарем.

DTPicker – это сокращение от слова DateTimePicker, не являющегося в VBA Excel ключевым словом, как и DatePicker.

Примеры кода VBA Excel с DTPicker

Программное создание DTPicker

Динамическое создание элемента управления DTPicker с помощью кода VBA Excel на пользовательской форме с любым именем:

Private Sub UserForm_Initialize()

Dim myDTPicker As DTPicker

With Me

.Height = 100

.Width = 200

‘Следующая строка создает новый экземпляр DTPicker

Set myDTPicker = .Controls.Add(«MSComCtl2.DTPicker», «dtp», True)

End With

With myDTPicker

.Top = 24

.Left = 54

.Height = 18

.Width = 72

.Font.Size = 10

End With

Set myDTPicker = Nothing

End Sub

Данный код должен быть размещен в модуле формы. Результат работы кода:

Применение свойства CustomFormat

Чтобы задать элементу управления DTPicker пользовательский формат отображения даты и времени, сначала необходимо присвоить свойству Format значение dtpCustom. Если этого не сделать, то, что бы мы не присвоили свойству CustomFormat, будет применен формат по умолчанию (dtpShortDate) или тот, который присвоен свойству Format.

В данном примере создается пользовательский формат для полей с календарем DTPicker1 и DTPicker2, размещенных на пользовательской форме, и отображаются в них текущие дата и время.

Private Sub UserForm_Initialize()

With DTPicker1

.Format = dtpCustom

.CustomFormat = «Год: yyyy; месяц: M; день: d»

.Value = Now

End With

With DTPicker2

.Format = dtpCustom

.CustomFormat = «Часы: H; минуты: m; секунды: s»

.Value = Now

End With

End Sub

Результат работы кода:

Таблица специальных символов и строк, задающих пользовательский формат даты и времени (регистр символов имеет значение):

Символы и строки	Описание
d	День месяца из одной или двух цифр.
dd	День месяца из двух цифр. К числу из одной цифры впереди добавляется ноль.
ddd	Сокращенное название дня недели из двух символов (Пн, Вт и т.д.).
dddd	Полное название дня недели.
h	Час из одной или двух цифр в 12-часовом формате.
hh	Час из двух цифр в 12-часовом формате. К часу из одной цифры впереди добавляется ноль.
H	Час из одной или двух цифр в 24-часовом формате.
HH	Час из двух цифр в 24-часовом формате. К часу из одной цифры впереди добавляется ноль.
m	Минута из одной или двух цифр.
mm	Минута из двух цифр. К минуте из одной цифры впереди добавляется ноль.
M	Месяц из одной или двух цифр.
MM	Месяц из двух цифр. К месяцу из одной цифры впереди добавляется ноль.
MMM	Сокращенное название месяца из трех символов.
MMMM	Полное название месяца.
s	Секунда из одной или двух цифр.
ss	Секунда из двух цифр. К секунде из одной цифры впереди добавляется ноль.
y	Год из одной или двух последних цифр.
yy	Год из двух последних цифр.
yyyy	Год из четырех цифр.

Создание границ интервала дат

Простенький пример, как задать интервал дат с начала месяца до текущего дня с помощью двух элементов управления DTPicker:

Private Sub UserForm_Initialize()

DTPicker1.Value = Now

DTPicker1.Day = 1

DTPicker2.Value = Now

End Sub

Результат работы кода, запущенного 23.11.2020:

DTPicker – это сокращение от слова DateTimePicker, не являющегося в VBA Excel ключевым словом, как и DatePicker.

Источник

Some users may not have the ability to use your DatePicker if their Excel is not formatted correctly. I developed code that will create a dateGetter userform, get the user’s date selection as a Global variable, and then delete the form. It should be compatible with most systems, though I haven’t tested it on others than my own. Give it a shot. If it works for you, give me a shout out….

August 2020:
Fixed a glitch — when selecting the original date that opened with the form the returning date was «00:00:00 AM» — I fixed that below to return the date showing in the label2 caption.

Also — MSForms reference is necessary for the dateGetter() subroutine to work properly or you get an error message when the forms objects are declared. I’ve added another subroutine that can add that reference through VBA code, or in the VBA Editor goto «Tools —> References» and select the MSForms refwerence. You must do this before attempting to run the dateGetter macro.

Public absDate As Date ' This Public Variable is necessary to pass selected date

Sub setGUIDReferences()
'   NOTE:  The dateGetter() sub will not work until the MSForms Reference is added to this workbook project
'   You can add the MSForms reference by running this sub first
'   Or go to Tools --> References and select the MSForms reference there
'   included below are several other common references you can use for other projects just uncomment them to add
'   *************************************************************************************************************

    On Error Resume Next
    'ThisWorkbook.VBProject.References.AddFromGuid "{000204EF-0000-0000-C000-000000000046}", 0, 0    '       Visual Basic For Applications
    'ThisWorkbook.VBProject.References.AddFromGuid "{00020813-0000-0000-C000-000000000046}", 0, 0    '       Microsoft Excel 16.0 Object Library
    'ThisWorkbook.VBProject.References.AddFromGuid "{00020430-0000-0000-C000-000000000046}", 0, 0    '       OLE Automation
    'ThisWorkbook.VBProject.References.AddFromGuid "{2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}", 0, 0    '       Microsoft Office 16.0 Object Library
    ThisWorkbook.VBProject.References.AddFromGuid "{0D452EE1-E08F-101A-852E-02608C4D0BB4}", 0, 0    '       Microsoft Forms 2.0 Object Library
    'ThisWorkbook.VBProject.References.AddFromGuid "{3050F1C5-98B5-11CF-BB82-00AA00BDCE0B}", 0, 0    '       Microsoft HTML Object Library
    'ThisWorkbook.VBProject.References.AddFromGuid "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}", 0, 0    '       Microsoft Internet Controls
    'ThisWorkbook.VBProject.References.AddFromGuid "{420B2830-E718-11CF-893D-00A0C9054228}", 0, 0    '       Microsoft Scripting Runtime
    'ThisWorkbook.VBProject.References.AddFromGuid "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}", 0, 0    '       Microsoft Windows Common Controls-2 6.0 (SP6)
    'ThisWorkbook.VBProject.References.AddFromGuid "{4AFFC9A0-5F99-101B-AF4E-00AA003F0F07}", 0, 0    '       Microsoft Access 16.0 Object Library
    'ThisWorkbook.VBProject.References.AddFromGuid "{0002E157-0000-0000-C000-000000000046}", 0, 0    '       Microsoft Visual Basic for Applications Extensibility 5.3
    'ThisWorkbook.VBProject.References.AddFromGuid "{F5078F18-C551-11D3-89B9-0000F81FE221}", 0, 0    '       Microsoft MSXML2 for XML Scraping
    On Error GoTo 0
End Sub

Sub dateGetter()
'   This creates dategetter userform for those without access to date picker
'   Bug Fixed: Aug 2020, Selecting Original Date was resulting in 12:00:00 AM

'*********
'   Note: MSForms Reference in Tools menu must be added to workbook first before this calendar script will work
'   You can add several commonly used references by running the "setGUIDReferences()" subroutine above.
'   Or go to Tools --> References and select the MSForms reference there
'*********

Dim myForm As Object, calendarForm As Object, newLabel As MSForms.Label, newSpinner As MSForms.SpinButton
Dim NewFrame As MSForms.Frame
Dim NewButton As MSForms.CommandButton, newButton2 As MSForms.CommandButton
Dim NewListBox As MSForms.ListBox
Dim smallDayArray
Dim xDiff As Long
Dim smallTextArray
Dim startDate As Date
Dim endDate As Date
    
    Set myForm = ThisWorkbook.VBProject.VBComponents.Add(3)
    
    'Create the User Form
    With myForm
        .Properties("Caption") = "Select Date Range"
        .Properties("Width") = 247.5
        .Properties("Height") = 350
    End With
    
    'create button
    Set NewButton = myForm.designer.Controls.Add("Forms.commandbutton.1")
    With NewButton
        .Name = "CommandButton1"
        .Top = 288
        .Left = 138
        .Width = 42
        .Height = 24
        .Font.Size = 10
        .Font.Name = "Tahoma"
        .Caption = "Cancel"
    End With
    
    'create button
    Set NewButton = myForm.designer.Controls.Add("Forms.commandbutton.1")
    With NewButton
        .Name = "CommandButton2"
        .Top = 288
        .Left = 186
        .Width = 42
        .Height = 24
        .Font.Size = 10
        .Font.Name = "Tahoma"
        .Caption = "Select"
    End With
    
    
    'create frame
    Set NewFrame = myForm.designer.Controls.Add("Forms.frame.1")
    With NewFrame
        .Name = "Frame1"
        .Top = 54
        .Left = 24
        .Width = 192
        .Height = 180
        .Font.Size = 9
        .Font.Name = "Tahoma"
    End With
    
    'Create label1
    Set newLabel = myForm.designer.Controls.Add("Forms.Label.1")
    With newLabel
        .Name = "Label1"
        .Top = 30
        .Left = 30
        .Width = 102
        .Height = 18
        .Font.Size = 12
        .Font.Name = "Tahoma"
        .ForeColor = RGB(128, 0, 0)
        .BackColor = RGB(256, 256, 256)
        .Caption = "November 2017"
    End With
    
    'Create label2
    Set newLabel = myForm.designer.Controls.Add("Forms.Label.1")
    With newLabel
        .Name = "Label2"
        .Top = 258
        .Left = 36
        .Width = 174
        .Height = 18
        .Font.Size = 12
        .Font.Name = "Tahoma"
        .ForeColor = RGB(0, 0, 0)
        .Caption = "01/01/2017"
    End With
    
    
    'Create SpinButton1
    Set newSpinner = myForm.designer.Controls.Add("Forms.spinbutton.1")
    With newSpinner
        .Name = "SpinButton1"
        .Top = 24
        .Left = 144
        .Width = 12.75
        .Height = 25
    End With
    
    'Create Calendar Header Labels
    smallDayArray = Array("S", "M", "T", "W", "T", "F", "S")
    smallTextArray = Array("day1", "day2", "day3", "day4", "day5", "day6", "day7")
    xDiff = 18
    For i = LBound(smallDayArray) To UBound(smallDayArray)
        Set lbl = NewFrame.Controls.Add("Forms.Label.1")
        With lbl
            .Name = smallTextArray(i)
            .Top = 6
            .Left = xDiff
            .Width = 12
            .Height = 18
            .Font.Size = 11
            .Font.Name = "Tahoma"
            .Caption = smallDayArray(i)
        End With
        xDiff = xDiff + 24
    Next i
    
    'Create Calendar boxes labels
    arrCounter = 1
    For j = 1 To 6
        xDiff = 12
        For k = 1 To 7
            Set lbl = NewFrame.Controls.Add("Forms.Label.1")
            With lbl
                .Name = "lb_" & arrCounter
                Select Case j
                    Case 1
                        .Top = 24
                    Case 2
                        .Top = 48
                    Case 3
                        .Top = 72
                    Case 4
                        .Top = 96
                    Case 5
                        .Top = 120
                    Case 6
                        .Top = 144
                End Select
                .Left = xDiff
                .Width = 18
                .Height = 18
                .Font.Size = 11
                .Font.Name = "Tahoma"
                .Caption = " " & arrCounter
                .ForeColor = RGB(128, 0, 0)
                .BackColor = RGB(256, 256, 256)
            End With
            arrCounter = arrCounter + 1
            xDiff = xDiff + 24
        Next k
    Next j
    ''add code for form module
    myForm.codemodule.insertlines 1, "Private Sub CommandButton1_Click()"
    myForm.codemodule.insertlines 2, "absDate = 0"
    myForm.codemodule.insertlines 3, "Unload Me"
    myForm.codemodule.insertlines 4, "End Sub"
    myForm.codemodule.insertlines 5, ""
    myForm.codemodule.insertlines 6, "Private Sub SpinButton1_SpinDown()"
    myForm.codemodule.insertlines 7, "Dim newDate1 As Date"
    myForm.codemodule.insertlines 8, "    newDate1 = DateValue(Left(Label1.Caption, Len(Label1.Caption) - 5) & " & Chr(34) & " 1, " & Chr(34) & " & Right(Label1.Caption, 4))"
    myForm.codemodule.insertlines 9, "    newDate1 = DateAdd(" & Chr(34) & "m" & Chr(34) & ", -1, newDate1)"
    myForm.codemodule.insertlines 10, "    Label1.Caption = MonthName(Month(newDate1)) & " & Chr(34) & " " & Chr(34) & " & Year(newDate1)"
    myForm.codemodule.insertlines 11, "    Call clearBoxes"
    myForm.codemodule.insertlines 12, "   Run fillCal(newDate1)"
    myForm.codemodule.insertlines 13, "End Sub"
    myForm.codemodule.insertlines 14, "Private Sub SpinButton1_SpinUp()"
    myForm.codemodule.insertlines 15, "Dim newDate1 As Date"
    myForm.codemodule.insertlines 16, "    newDate1 = DateValue(Left(Label1.Caption, Len(Label1.Caption) - 5) & " & Chr(34) & " 1, " & Chr(34) & " & Right(Label1.Caption, 4))"
    myForm.codemodule.insertlines 17, "    newDate1 = DateAdd(" & Chr(34) & "m" & Chr(34) & ", 1, newDate1)"
    myForm.codemodule.insertlines 18, "    Label1.Caption = MonthName(Month(newDate1)) & " & Chr(34) & " " & Chr(34) & " & Year(newDate1)"
    myForm.codemodule.insertlines 19, "    Call clearBoxes"
    myForm.codemodule.insertlines 20, "    Run fillCal(newDate1)"
    myForm.codemodule.insertlines 21, "End Sub"
    myForm.codemodule.insertlines 22, "Function dhDaysInMonth2(Optional dtmDate As Date = 0) As Integer"
    myForm.codemodule.insertlines 23, "    ' Return the number of days in the specified month.  Written by Chip Pierson"
    myForm.codemodule.insertlines 24, "    If dtmDate = 0 Then"
    myForm.codemodule.insertlines 25, "        ' Did the caller pass in a date? If not, use"
    myForm.codemodule.insertlines 26, "        ' the current date."
    myForm.codemodule.insertlines 27, "        dtmDate = Date"
    myForm.codemodule.insertlines 28, "    End If"
    myForm.codemodule.insertlines 29, "    dhDaysInMonth2 = DateSerial(Year(dtmDate), _ "
    myForm.codemodule.insertlines 30, "     Month(dtmDate) + 1, 1) - _ "
    myForm.codemodule.insertlines 31, "     DateSerial(Year(dtmDate), Month(dtmDate), 1)"
    myForm.codemodule.insertlines 32, "End Function"
    myForm.codemodule.insertlines 33, "Public Sub UserForm_Activate()"
    myForm.codemodule.insertlines 34, "Dim currentDate As Date"
    myForm.codemodule.insertlines 35, ""
    myForm.codemodule.insertlines 36, " For i = 1 To 42" & vbNewLine
    myForm.codemodule.insertlines 37, "     txt = txt & " & Chr(34) & "Private Sub lb_" & Chr(34) & " & i & " & Chr(34) & "_Click()" & Chr(34) & " & vbNewLine" & vbNewLine
    myForm.codemodule.insertlines 38, "     txt = txt & " & Chr(34) & "Dim newDate As Date" & Chr(34) & " & vbNewLine" & vbNewLine
    myForm.codemodule.insertlines 39, " txt = txt & " & Chr(34) & "newDate = DateValue(Mid(Label1.Caption, 1, Len(Label1.Caption) - 5) &" & Chr(34) & " & Chr(34) &   " & Chr(34) & Chr(34) & " & lb_" & " & i & " & Chr(34) & ".Caption & " & Chr(34) & " & Chr(34) & " & Chr(34) & ", " & Chr(34) & " & Chr(34) & " & Chr(34) & " & Right(Label1.Caption, 4))" & Chr(34) & " & vbNewLine" & vbNewLine
    myForm.codemodule.insertlines 40, "     txt = txt & " & Chr(34) & "Label2.Caption = " & Chr(34) & " & Chr(34) & " & Chr(34) & "Date:  " & Chr(34) & " & Chr(34) & " & Chr(34) & " & newDate" & Chr(34) & " & vbNewLine" & vbNewLine
    myForm.codemodule.insertlines 41, "txt = txt & " & Chr(34) & "End Sub" & Chr(34) & " & vbNewLine" & vbNewLine
    myForm.codemodule.insertlines 42, "Next i" & vbNewLine
    myForm.codemodule.insertlines 43, ""
    myForm.codemodule.insertlines 44, "Label2.Caption =  Chr(34) &  Chr(34) "
    myForm.codemodule.insertlines 45, "currentDate = DateValue(Month(Date) & " & Chr(34) & " 1" & Chr(34) & " & " & Chr(34) & ", " & Chr(34) & " & Year(Date))"
    myForm.codemodule.insertlines 46, "Run fillCal(currentDate)"
    myForm.codemodule.insertlines 47, "End Sub"
    myForm.codemodule.insertlines 48, "Function fillCal(startDate As Date)"
    myForm.codemodule.insertlines 49, "Dim currentDayOfMonth As Integer, i As Integer"
    myForm.codemodule.insertlines 50, "currentDayOfMonth = Day(Date)"
    myForm.codemodule.insertlines 51, "Dim startCal As Date, currentMonth as Integer"
    myForm.codemodule.insertlines 52, "Dim labelArray, sumVar3 As Long"
    myForm.codemodule.insertlines 53, "    Label2.Caption = " & Chr(34) & "" & Chr(34)
    myForm.codemodule.insertlines 54, "    labelArray = Array(" & Chr(34) & "lb_1" & Chr(34) & ", " & Chr(34) & "lb_2" & Chr(34) & ", " & Chr(34) & "lb_3" & Chr(34) & ", " & Chr(34) & "lb_4" & Chr(34) & ", " & Chr(34) & "lb_5" _
                                                                & Chr(34) & ", " & Chr(34) & "lb_6" & Chr(34) & ", " & Chr(34) & "lb_7" & Chr(34) & ", " & Chr(34) & "lb_8" & Chr(34) & ", " & Chr(34) & "lb_9" & Chr(34) & ", " & Chr(34) _
                                                                & "lb_10" & Chr(34) & ", " & Chr(34) & "lb_11" & Chr(34) & ", " & Chr(34) & "lb_12" & Chr(34) & ", " & Chr(34) & "lb_13" & Chr(34) & ", " & Chr(34) & "lb_14" & Chr(34) & ", " & Chr(34) & "lb_15" & Chr(34) & ",  _"
    myForm.codemodule.insertlines 55, "                      " & Chr(34) & "lb_16" & Chr(34) & ", " & Chr(34) & "lb_17" & Chr(34) & ", " & Chr(34) & "lb_18" & Chr(34) & ", " & Chr(34) & "lb_19" & Chr(34) & ", " & Chr(34) & "lb_20" & Chr(34) & ", " & _
                                                                Chr(34) & "lb_21" & Chr(34) & ", " & Chr(34) & "lb_22" & Chr(34) & ", " & Chr(34) & "lb_23" & Chr(34) & ", " & Chr(34) & "lb_24" & Chr(34) & ", " & Chr(34) & "lb_25" & Chr(34) & ", " & _
                                                                Chr(34) & "lb_26" & Chr(34) & ", " & Chr(34) & "lb_27" & Chr(34) & ", " & Chr(34) & "lb_28" & Chr(34) & ", " & Chr(34) & "lb_29" & Chr(34) & ", " & Chr(34) & "lb_30" & Chr(34) & ", " & Chr(34) & "lb_31" & Chr(34) & ", _"
    myForm.codemodule.insertlines 56, "                      " & Chr(34) & "lb_32" & Chr(34) & ", " & Chr(34) & "lb_33" & Chr(34) & ", " & Chr(34) & "lb_34" & Chr(34) & ", " & Chr(34) & "lb_35" & Chr(34) & ", " & Chr(34) & "lb_36" & Chr(34) & ", " & _
                                                                Chr(34) & "lb_37" & Chr(34) & ", " & Chr(34) & "lb_38" & Chr(34) & ", " & Chr(34) & "lb_39" & Chr(34) & ", " & Chr(34) & "lb_40" & Chr(34) & ", " & Chr(34) & "lb_41" & Chr(34) & ", " & Chr(34) & "lb_42" & Chr(34) & ")"
    myForm.codemodule.insertlines 57, "    Label1 = MonthName(Month(startDate)) & " & Chr(34) & " " & Chr(34) & " & Year(startDate)"
    myForm.codemodule.insertlines 58, "    sumVar3 = Weekday(startDate) - 1"
    myForm.codemodule.insertlines 59, "    "
    myForm.codemodule.insertlines 60, "    For i = LBound(labelArray) To UBound(labelArray)"
    myForm.codemodule.insertlines 61, "            Me.Controls(labelArray(i)).Caption = " & Chr(34) & "" & Chr(34) & ""
    myForm.codemodule.insertlines 62, "    Next i"
    myForm.codemodule.insertlines 63, "    "
    myForm.codemodule.insertlines 64, "     For i = 1 To dhDaysInMonth2(startDate)"
    myForm.codemodule.insertlines 65, "         Me.Controls(labelArray(sumVar3)).Caption = i"
    myForm.codemodule.insertlines 66, "         If currentDayOfMonth = i And month(Date) = Month(StartDate)  And Year(Date) = Year(StartDate) Then"
    myForm.codemodule.insertlines 67, "             Me.Controls(labelArray(sumVar3)).BackColor = RGB(256, 0, 0)"
    myForm.codemodule.insertlines 68, "             Me.Controls(labelArray(sumVar3)).ForeColor = RGB(256, 256, 256)"
    myForm.codemodule.insertlines 69, "             Label2.Caption = " & Chr(34) & "Date:  " & Chr(34) & " & DateValue(Month(startDate) & " & Chr(34) & "/" & Chr(34) & " & i & " & Chr(34) & "/" & Chr(34) & " & Year(startDate))"
    myForm.codemodule.insertlines 70, "        End If"
    myForm.codemodule.insertlines 71, "        sumVar3 = sumVar3 + 1"
    myForm.codemodule.insertlines 72, "     Next i"
    myForm.codemodule.insertlines 73, "    "
    myForm.codemodule.insertlines 74, "End Function"
    myForm.codemodule.insertlines 75, "Private Sub CommandButton2_Click()"
    myForm.codemodule.insertlines 76, "    absDate = Replace(Me.Label2.Caption, " & Chr(34) & "Date:  " & Chr(34) & ", " & Chr(34) & Chr(34) & "):Unload Me"
    myForm.codemodule.insertlines 77, "End Sub"
    myForm.codemodule.insertlines 78, "Private Sub clearBoxes()"
    myForm.codemodule.insertlines 79, "Dim labelArray"
    myForm.codemodule.insertlines 80, "     Label2.Caption = " & Chr(34) & "" & Chr(34)
    myForm.codemodule.insertlines 81, "    labelArray = Array(" & Chr(34) & "lb_1" & Chr(34) & ", " & Chr(34) & "lb_2" & Chr(34) & ", " & Chr(34) & "lb_3" & Chr(34) & ", " & Chr(34) & "lb_4" & Chr(34) & ", " & Chr(34) & "lb_5" _
                                                                & Chr(34) & ", " & Chr(34) & "lb_6" & Chr(34) & ", " & Chr(34) & "lb_7" & Chr(34) & ", " & Chr(34) & "lb_8" & Chr(34) & ", " & Chr(34) & "lb_9" & Chr(34) & ", " & Chr(34) _
                                                                & "lb_10" & Chr(34) & ", " & Chr(34) & "lb_11" & Chr(34) & ", " & Chr(34) & "lb_12" & Chr(34) & ", " & Chr(34) & "lb_13" & Chr(34) & ", " & Chr(34) & "lb_14" & Chr(34) & ", " & Chr(34) & "lb_15" & Chr(34) & ",  _"
    myForm.codemodule.insertlines 82, "                      " & Chr(34) & "lb_16" & Chr(34) & ", " & Chr(34) & "lb_17" & Chr(34) & ", " & Chr(34) & "lb_18" & Chr(34) & ", " & Chr(34) & "lb_19" & Chr(34) & ", " & Chr(34) & "lb_20" & Chr(34) & ", " & _
                                                                Chr(34) & "lb_21" & Chr(34) & ", " & Chr(34) & "lb_22" & Chr(34) & ", " & Chr(34) & "lb_23" & Chr(34) & ", " & Chr(34) & "lb_24" & Chr(34) & ", " & Chr(34) & "lb_25" & Chr(34) & ", " & _
                                                                Chr(34) & "lb_26" & Chr(34) & ", " & Chr(34) & "lb_27" & Chr(34) & ", " & Chr(34) & "lb_28" & Chr(34) & ", " & Chr(34) & "lb_29" & Chr(34) & ", " & Chr(34) & "lb_30" & Chr(34) & ", " & Chr(34) & "lb_31" & Chr(34) & ", _"
    myForm.codemodule.insertlines 83, "                      " & Chr(34) & "lb_32" & Chr(34) & ", " & Chr(34) & "lb_33" & Chr(34) & ", " & Chr(34) & "lb_34" & Chr(34) & ", " & Chr(34) & "lb_35" & Chr(34) & ", " & Chr(34) & "lb_36" & Chr(34) & ", " & _
                                                                Chr(34) & "lb_37" & Chr(34) & ", " & Chr(34) & "lb_38" & Chr(34) & ", " & Chr(34) & "lb_39" & Chr(34) & ", " & Chr(34) & "lb_40" & Chr(34) & ", " & Chr(34) & "lb_41" & Chr(34) & ", " & Chr(34) & "lb_42" & Chr(34) & ")"
    myForm.codemodule.insertlines 84, "      For i = lbound(labelArray) to ubound(labelArray)"
    myForm.codemodule.insertlines 85, "         Me.Controls(labelArray(i)).BackColor = RGB(256, 256, 256)"
    myForm.codemodule.insertlines 86, "         Me.Controls(labelArray(i)).ForeColor = RGB(0, 0, 0)"
    myForm.codemodule.insertlines 87, "      next i"
    myForm.codemodule.insertlines 88, "End Sub"
    '   add click controls for date label boxes
    Dim myCounter As Long
    myCounter = 89
        For i = 1 To 42
            myForm.codemodule.insertlines myCounter, "Private Sub lb_" & i & "_Click()"
            myCounter = myCounter + 1
            myForm.codemodule.insertlines myCounter, "Dim newDate As Date"
            myCounter = myCounter + 1
            myForm.codemodule.insertlines myCounter, "Call clearBoxes"
            myCounter = myCounter + 1
            myForm.codemodule.insertlines myCounter, "absDate = DateValue(Left(Label1.Caption, Len(Label1.Caption) - 5) & " & Chr(34) & Chr(32) & Chr(34) & " & lb_" & i & ".Caption & " & Chr(34) & ", " & Chr(34) & Chr(38) & " Right(Label1.Caption, 4))"
            myCounter = myCounter + 1
            myForm.codemodule.insertlines myCounter, "Label2.Caption = " & Chr(34) & "Date:  " & Chr(34) & " & absDate" & vbNewLine
            myCounter = myCounter + 1
            myForm.codemodule.insertlines myCounter, "lb_" & i & ".backcolor = rgb(256,0,0)"
            myCounter = myCounter + 1
            myForm.codemodule.insertlines myCounter, "lb_" & i & ".forecolor = rgb(256,256,256)"
            myCounter = myCounter + 1
            myForm.codemodule.insertlines myCounter, "End Sub" & vbNewLine
            myCounter = myCounter + 1
    Next i
    'Add and show new userform
    absDate = Format(Date, "mm/dd/yyyy")
    Set calendarForm = VBA.UserForms.Add(myForm.Name)
    calendarForm.Show
    
    
    If absDate <> 0 Then
    '   Here is where you put your code to to use the selected date
    '   whhich is in the global variabole "absDate"
        startDate = absDate
        Debug.Print "Your First Date is " & startDate
    Else
        Beep
        MsgBox "You did not select a date"
        GoTo endItAll
    End If
    
    
     
endItAll:
    '   Uncomment the following line if you want to delete the form after using it
    ThisWorkbook.VBProject.VBComponents.Remove myForm
End Sub
Function dhDaysInMonth(Optional dtmDate As Date = 0) As Integer
    ' Return the number of days in the specified month.  Written by Chip Pierson
    If dtmDate = 0 Then
        ' Did the caller pass in a date? If not, use
        ' the current date.
        dtmDate = Date
    End If
    dhDaysInMonth2 = DateSerial(Year(dtmDate), _
     Month(dtmDate) + 1, 1) - _
     DateSerial(Year(dtmDate), Month(dtmDate), 1)
End Function

Источник

Option Explicit
'---------------------------------------------------------------------------------------
' Решение       : Календарь
' Дата и время  : 14 января 2015  23:02
' Автор         : Night Ranger
'                 Яндекс.Деньги - 410012757639478
'                 [email]Exingsteem@yandex.ru[/email]
'                 [url]https://www.cyberforum.ru/vba/[/url]
' Описание      : Этот пример наглядно демонстрирует, как можно использовать календарь
'                 без подключения его к проекту, для этого нужна только форма
'                 совместимость версий любая
'
'                 В этой версии, теперь есть возможность запускать календарь от процедуры
'                 ShowCalendar, и указать там параметры SetDate и UnderRussianStandard
'                 Добавленна кнопка Ok, и форма помнит свою позицию
'---------------------------------------------------------------------------------------
Const jstart = 8, istart = 8 'Стартовые точки
Const gap = 5 'Разрыв
Const twip = 18 'Прямоугольник
Const cc = 6 'Размерность массива
Dim tt(cc, cc) As MSForms.ToggleButton, lb As MSForms.Label
Dim WithEvents fr As MSForms.Frame, WithEvents tb As MSForms.ToggleButton, WithEvents btn As MSForms.CommandButton
Dim WithEvents cbMonth As MSForms.ComboBox, WithEvents cbYear As MSForms.ComboBox
Dim WithEvents chbx As MSForms.CheckBox, WithEvents ok As MSForms.CommandButton
Dim iNext&, cr As Boolean, i&, j&, jj&, v, a$(), tbClick As Boolean, URStandard As Boolean
 
Public ThisDate As Date 'Переменная в которой храниться выбранная дата
 
Private Sub ok_Click()
    'Здесь могут быть дальнейшие инструкции после выбора даты
    'Например дату в удобном формате можно поместить в активную ячейку
    '----------------------------------------------------------------
    
    '
    '
    '
 
    ActiveCell = TextResult
    '----------------------------------------------------------------
    If chbx.Value Then Me.Hide
End Sub
 
Public Sub ShowCalendar( _
    Optional ByVal SetDate As Date, _
    Optional ByVal UnderRussianStandard As Boolean = 1)
    'ShowCalendar -Процедура вызова с параметрами
    'SetDate -Устанавливает возможность показа календаря c этой даты
    'UnderRussianStandard -Устанавливает возможность исправлять: 1 январь на 1 января
    If CDbl(SetDate) Then
        cr = False
        ThisDate = SetDate
        cbMonth.ListIndex = Month(ThisDate) - 1
        cbYear.Text = Year(ThisDate): cr = True: Update
    End If
    URStandard = UnderRussianStandard
    Me.Show
End Sub
 
Private Function TextResult$()
    TextResult = FormatDateTime(ThisDate, vbLongDate)
    If URStandard Then
        TextResult = Format(ThisDate, "[$-FC19]d mmmm yyyy г.")
        
'        a = Split(TextResult)
'        If Right$(a(1), 1) Like "[йЙьЬ]" Then
'            Mid$(a(1), Len(a(1)), 1) = "я"
'        ElseIf Right$(a(1), 1) Like "[Тт]" Then a(1) = a(1) & "а"
'        End If
'        TextResult = Join(a)
    End If
End Function
 
 
 
Private Sub UserForm_Initialize()
    Dim maxWidth&, Width1&, jNext&
    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")
    Set ok = Me.Controls.Add("Forms.CommandButton.1", "ok")
    Set chbx = Me.Controls.Add("Forms.CheckBox.1", "chbx")
    
    With lb: .Move jstart, istart, Width1
        .Font.Size = 15: .Font.Bold = 1
        iNext = iNext + .Height + gap
        jNext = jNext + .Width + gap
    End With
    With cbMonth: .Move jNext, istart, (Width1 - gap * 2)  2, lb.Height: .Style = 2
        For i = 1 To 12: .AddItem Format(DateSerial(0, i, 1), "mmmm"): Next
        jNext = jNext + .Width + gap
    End With
    With cbYear: .Move jNext, istart, (Width1 - gap * 2)  2, lb.Height: .Style = 2
        For i = 1899 To Year(ThisDate) + 100
            .AddItem CStr(i)
        Next
    End With
    
    iNext = lb.Top + lb.Height + gap
    
    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
        .ForeColor = IIf(j >= 5, vbRed, vbBlue)
        .BackColor = IIf(i, vbButtonFace, vbScrollBars)
    End With: Next j, i
    jNext = jstart
    With ok: .Move jNext, iNext + fr.Height + gap, lb.Width, lb.Height: .Caption = "Ok"
        .AutoSize = 1: jNext = jNext + .Width + gap
    End With
    
    With btn: .Move jNext, iNext + fr.Height + gap, lb.Width, lb.Height: .Caption = "Сегодня"
        .AutoSize = 1: jNext = jNext + .Width + gap
    End With
 
    With chbx: .Move jNext, btn.Top, (jstart + maxWidth) - jNext
        .Caption = "Скрываться после выбора или Ok"
        .Value = GetSetting("Ms Office", "Calendar", "chbx", chbx.Value)
    End With
    
 
    Call btn_Click: Filling: lbUpdate
 
    With Me
        .Height = btn.Top + twip * 3
        .Width = jstart + maxWidth + twip
        If Application.Left > -100 Then
            .StartUpPosition = 0
            .Left = GetSetting("Ms Office", "Calendar", "Left", .Left)
            .Top = GetSetting("Ms Office", "Calendar", "Top", .Top)
            If .Left <= 0 Or .Left > (Application.Left + Application.Width - 100) Or _
            .Top <= 0 Or .Top > (Application.Top + Application.Height - 100) Then
                'Если сохраненная ранее позиция вышла за предел экрана
                .StartUpPosition = 2
            End If
        End If
    End With
 
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
        ThisDate = DateSerial(Year(ThisDate), cbMonth.ListIndex + 2, 0)
         lb.Caption = Format(ThisDate, "mmmm yyyy")
    End If
End Sub
 
Private Sub btn_Click()
    cr = False
    ThisDate = Date
    cbMonth.ListIndex = Month(ThisDate) - 1
    cbYear.Text = Year(ThisDate): cr = True: Update
    
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_MouseDown(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)
                    If (.Name = tb.Name) Then
                        ThisDate = DateSerial(cbYear.Text, cbMonth.ListIndex + 1, .Caption)
                        .Value = 1: tbClick = 1: tb_Click: tbClick = 0 'Выбор произведен !
                    Else: .Value = 0
                    End If
    End With: Next j, i: End If: End With: End If
End Sub
 
Private Sub chbx_Click()
    If cr = False Then Exit Sub
    SaveSetting "Ms Office", "Calendar", "chbx", chbx.Value
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 Update(): Call lbUpdate:  Filling: End Sub
Private Sub tb_Click(): If tbClick = False Then Exit Sub Else ok_Click
End Sub
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    With Me 'Перед закрытием запомнить позицию
        SaveSetting "Ms Office", "Calendar", "Left", .Left
        SaveSetting "Ms Office", "Calendar", "Top", .Top
    End With
End Sub

Источник

Date Picker Calendar in Excel VBA

Oftentimes, users want to click a button and select a date. This is no different for Excel developers. Check out this ActiveX control by Microsoft that allows users to do just that. It’s a little old school looking, but actually has quite a nice feel to it.

Start by creating a userform and enabling the control by Right-clicking on the Tools menu and click Add additional tools

Now, let’s add this to the userform!

In the downloadable workbook, you’ll see the control was renamed to ‘fCal’. When you double-click the control you’ll see the following code which is the DateClick event of that control:

code snippet

This userform cleverly has two labels to store relevant info on the Userform that summoned it. 1.) The name of the userform that called it and 2.) The name of the control or textbox that needs the date sent to it.

Then, this code above loops through all userforms in your project until it finds one that matches the label for the Userform (lblUF) and the label for the textbox needed (lblCtrlName).

Also, you may need to enable Microsoft Windows Common Controls -2 6.0 (SP6) by using Tools->References and clicking:

Stop Wasting Your Time

Experience Ultimate Excel Automation & Learn to “Make Excel Do Your Work For You”

Watch Us Make a Calendar In Excel On YouTube:

This website uses cookies to improve your experience. We’ll assume you’re ok with this, but you can opt-out if you wish. Cookie settingsACCEPT

Wait A Second!

Thank you for visiting! Here’s a FREE gift for you!

Enroll In My FREE VBA Crash Course For FREE!

Learn how to write macros from scratch, make buttons and simple procedures to automate tasks.

Источник

Ah, The complexities of automation! The versatile and multifaceted world of Excel VBA offers an array of tools and functionalities to streamline tasks and make life easier. Yet, despite its vast offerings, not all versions of Excel VBA come equipped with the desired calendar control, one that would allow for the selection of dates in a visually appealing manner, instead of the tedious manual input of dates into cells or text boxes. But fear not! For we shall embark on a journey, one that will unravel the mysteries of crafting a customized, dynamic calendar in Excel VBA using VBA User Forms and Command Buttons.

Step 1: Baffling Beginnings

Our journey begins with the creation of a User Form, a task achieved by navigating to the VBA editor and right-clicking on the ‘Project’ option in the Project Explorer, selecting ‘Insert’, followed by ‘User Form’. Voila! A new User Form will mysteriously appear, waiting to be customized to your whims and fancies.

Step 2: Commanding Conundrum

Next, we add a series of Command Buttons to the User Form, buttons that will act as our navigational tools, leading us through the calendar and enabling us to switch between months and years. And, to further confuse the matter, we add combo boxes, providing the option for the user to choose the month and year.

Step 3: Cryptic Code

With the controls in place, it’s time to delve into the code, to bring our dynamic calendar to life. To start, we write a function to generate the calendar based on the selected month and year, populating it with the correct number of days and illuminating the current date. And, as a bonus, we add a feature to highlight already existing dates in the text box or label by comparing the dates and marking them with a small star symbol, making the calendar even more user-friendly.

Watch the step-by-step video tutorials to learn the design and coding

Step 4: Calling the Calendar

Finally, with the dynamic calendar fully functional, we can summon it in our VBA project by using the ‘SelectedDate’ function. There are two methods to call this function:

Method 1: Call Calendar.SelectedDate(Me.TextBox1)

Method 2: Me.TextBox1.Value = Calendar.SelectedDate

The first method calls the calendar control and passes the value of the text box to the ‘SelectedDate’ function, while the second method calls the calendar control and assigns the selected date to the text box.

Move the Calendar control in from One to another VBA Project:

Just move this calendar form in your VBA project just drag it using mouse

Move Calendar to your VBA Project using Mouse

Bursting with Conclusions

And there you have it, a perplexing puzzle solved, a dynamic calendar crafted with the use of Excel VBA User Forms and Command Buttons. The calendar control, now at your beck and call, can be used in various VBA projects, and is easily summoned using the ‘SelectedDate’ function. And, with a few modifications, additional functionality, such as highlighting of existing dates or changes in style and appearance, can be added to further confuse and bewilder.

This Fully Functional Dynamic Calendar Control in VBA, we have designed to use in VBA project. You can use it for Excel Cells, Textbox, Label and Command Button etc. It is extremely easy to call this Calendar for your VBA Project. You can call this with two methods.

Click here to download this Fully Function Calendar Control

Источник