Работа с календарем в excel vba

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:

Watch Us Make a Calendar In Excel On YouTube:

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

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

'---------------------------------------------------------------------------------------
' Author : Дмитрий (The_Prist) Щербаков
'          Профессиональная разработка приложений для MS Office любой сложности
'          Проведение тренингов по MS Excel
'          https://www.excel-vba.ru
'          info@excel-vba.ru
'          WebMoney - R298726502453; Яндекс.Деньги - 41001332272872
' Purpose: Загрузка праздничных дат из производственного календаря с сайта data.gov.ru
'          https://www.excel-vba.ru/chto-umeet-excel/proizvodstvennyj-kalendar-v-excel-vba-i-power-qwery/
'---------------------------------------------------------------------------------------
Option Explicit
'объявление функции API - URLDownloadToFile для скачивания файла
'Идет в самом начале, т.к. API функции необходимо объявлять именно здесь
'   работает на любых ПК под управлением ОС Windows
'   на MAC код работать не будет
#If Win64 Then 'для операционных систем с 64-разрядной архитектурой
    Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
            (ByVal pCaller As LongLong, ByVal szURL As String, ByVal szFileName As String, _
             ByVal dwReserved As LongLong, ByVal lpfnCB As LongLong) As LongLong
#Else
    #If VBA7 Then 'для любых операционных систем с офисом 2010 и выше
        Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
            (ByVal pCaller As LongPtr, ByVal szURL As String, ByVal szFileName As String, _
                ByVal dwReserved As Long, ByVal lpfnCB As LongPtr) As LongPtr
    #Else 'для 32-разрядных операционных систем
        Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
                                        (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
                                        ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
    #End If
#End If
 
'Основная процедура поиска ссылки и скачивания календаря
'    в ходе работы использует остальные функции
Sub LoadCalendar()
    Dim res, response$, surl$, sex$, sFName$, sMsg$
    Dim oXMLHTTP As Object
    Dim lp&, le&, le2&
    Dim wbPrCalendar As Workbook
 
    Application.ScreenUpdating = False
    Err.Clear
    On Error GoTo err_handler
    'подключаемся к сайту
    Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP")
    With oXMLHTTP
        .Open "GET", "https://data.gov.ru/opendata/7708660670-proizvcalendar", False
        .send
        'ждем пока страница прогрузится
        Do While .readyState <> 4
          DoEvents
        Loop
        'запоминаем исходный код страницы(для поиска ссылки)
        response = .responseText
    End With
    If Len(response) Then
        'ищем место с ссылкой на наш CSV
        '   их там несколько, нам нужна "Гиперссылка (URL) на набор"
        lp = InStr(1, response, "Гиперссылка (URL) на набор", 1)
        If lp > 0 Then
            'если нашли - ищем начало гиперссылки для скачивания(по ключевым http)
            le = InStr(lp, response, "http", 1)
            If le > 0 Then
                'если это CSV - берем его
                le2 = InStr(le, response, ".csv", 1)
                'CSV не нашли - пробуем найти xlsx(что вряд ли, но лушче попробовать)
                If le2 = 0 Then
                    le2 = InStr(le, response, ".xls", 1)
                End If
                If le2 > 0 Then
                    'формируем только адрес ссылки для скачивания
                    lp = InStr(le2, response, Chr(34), 1)
                    surl = Mid(response, le, lp - le)
                    lp = InStrRev(surl, ".")
                    sex = Mid(surl, lp, Len(surl) - lp + 1)
                    'пробуем скачать при помощи функции API
                    Set wbPrCalendar = CallDownload(surl, "prod_cal" & sex)
                    'обрабатываем скачанный файл
                    If Not wbPrCalendar Is Nothing Then
                        wbPrCalendar.Activate
                        sFName = wbPrCalendar.FullName
                        'преобразуем данные в файле в столбец дат
                        Call FillProdCalend(wbPrCalendar)
                        wbPrCalendar.Close 0
                        DoEvents
                        On Error Resume Next
                        'удаляем после обработки
                        Kill sFName
                        Err.Clear
                        DoEvents
                        sMsg = "Производственный календарь успешно обновлен"
                    End If
                End If
            End If
        End If
    End If
'если будет какая-то ошибка - код перейдет сюда и покажет текст ошибки
err_handler:
    If Err.Number <> 0 Then
        sMsg = "Не удалось обновить Производственный календарь." & vbNewLine & _
               "Ошибка: " & Err.Description
    End If
    Application.ScreenUpdating = True
    MsgBox sMsg, vbInformation, "www.excel-vba.ru"
End Sub
 
'---------------------------------------------------------------------------------------
' File   : mDownloadFileFromURL
' Purpose: код позволяет скачивать файлы из интернета по указанной ссылке
'          https://www.excel-vba.ru/chto-umeet-excel/kak-skachat-fajl-iz-interneta-po-ssylke/
'---------------------------------------------------------------------------------------
Function CallDownload(sFileURL As String, sFileName As String) As Workbook
    'переменная для хранения пути к папке
    Dim sFilePath As String, ToPathName As String
    Dim h
 
    sFilePath = Environ("temp")
    If Right(sFilePath, 1) <> "" Then sFilePath = sFilePath & ""
    ToPathName = sFilePath & sFileName
    'проверяем есть ли файл с таким же именем в выбранной папке
    If Dir(ToPathName, 16) <> "" Then
        On Error Resume Next
        Kill ToPathName
        DoEvents
        On Error GoTo 0
    End If
    'если не возникло ошибок при удалении файла - скачиваем его по ссылке
    '   если ошибка была - значит такой файл уже открыт
    '   и в дальнейшем все равно получим ошибку
    If Err.Number = 0 Then
        'вызов функции API для непосредственно скачивания
        h = (URLDownloadToFile(0, sFileURL, ToPathName, 0, 0) = 0)
        'если h = False - файл не удалось скачать, показываем инф.окно
        If h = False Then
            MsgBox "Невозможно скачать файл." & vbNewLine & _
                    "Возможно, у Вас нет прав на создание файлов в папке '" & sFilePath & "'.", _
                    vbInformation, "www.excel-vba.ru"
                    Set CallDownload = Nothing
                    Exit Function
        Else 'файл успешно скачан
            If IsBookOpen(sFileName) Then
                MsgBox "Файл с именем '" & sFileName & "' уже открыт. Закройте открытый файл и повторите попытку.", vbCritical, "www.excel-vba.ru"
            Else
                Set CallDownload = Application.Workbooks.Open(ToPathName)
            End If
        End If
    Else
        Set CallDownload = Nothing
    End If
End Function
'функция заполнения листа "ProdCalend" датами из производственного календаря
'   предварительно функция разбивает даты на отдельные
'   т.к. изначально они записаны в виде перечня дней для каждого месяца
Function FillProdCalend(wbCSV As Workbook)
    Dim acsv, ares()
    Dim dic As Object
    Dim llastr&, lr&, lc&, lcnt&
    Dim ly&, lm&, ld&
    Dim asp, sd$, s$, x
    Dim dt As Date
 
    With wbCSV.Worksheets(1)
        llastr = .Cells(.Rows.Count, 1).End(xlUp).Row
        acsv = .Cells(1, 1).Resize(llastr, 13).Value
    End With
    With ThisWorkbook.Sheets("ProdCalend")
        'очищаем лист от старых данных
        .Columns(1).Cells.Clear
        'здесь будем хранить список уникальных дат
        Set dic = CreateObject("scripting.dictionary")
        dic.comparemode = 1
        'просматриваем каждую строку файла(год), начиная со 2-й
        For lr = 2 To UBound(acsv, 1)
            If IsNumeric(acsv(lr, 1)) Then
                ly = Val(Trim(acsv(lr, 1)))
                'просматриваем каждый столбец файла(месяц), начиная со 2-го
                For lc = 2 To UBound(acsv, 2)
                    lm = lc - 1
                    s = acsv(lr, lc)
                    s = Trim(s)
                    'убираем символы +
                    'которыми обозначаются перенесенные праздничные дни
                    s = Replace(s, "+", "")
                    If Len(s) Then
                        'разбиваем единую строку вида 1,2,3,4,6*,7,9,10,16,17,23,24,30,31
                        'на отдельные дни
                        asp = Split(s, ",")
                        'перебор каждого дня и создание из него даты
                        'с запоминанием в словарь дат dic
                        For Each x In asp
                            s = Trim(x)
                            'не учитываем даты со знаком * - это сокращенные предпраздничные дни
                            If InStr(1, s, "*", 1) = 0 Then
                                If Len(s) Then
                                    ld = Val(s)
                                    dt = DateSerial(ly, lm, ld)
                                    If Not dic.exists(dt) Then
                                        dic.Add dt, 0&
                                    End If
                                End If
                            End If
                        Next
                    End If
                Next
            End If
        Next
        'даты есть - записываем на лист
        '   можно было поступить проще
        '   .Cells(2, 1).Resize(dic.Count).Value = Application.Transpose(dic.Keys)
        '   но этот метод опасен тем, что порой может выгрузить не все данные
        '   хотя в данном конкретном случае это очень маловероятно, т.к. ограничения касаются 
        '   кол-ва строк в 65536 и текста в каждой строке до 255 символов
        If dic.Count > 0 Then
            ReDim ares(1 To dic.Count, 1 To 1)
            lr = 0
            For Each x In dic.keys
                lr = lr + 1
                ares(lr, 1) = x
            Next
            .Cells(1, 1).Value = "Праздники и выходные"
            .Cells(2, 1).Resize(dic.Count).Value = ares
        End If
    End With
End Function
 
'Функция проверки - открыта ли книга с заданным именем
'подробнее:
'        https://www.excel-vba.ru/chto-umeet-excel/kak-proverit-otkryta-li-kniga/
Function IsBookOpen(wbName As String) As Boolean
    Dim wbBook As Workbook
    For Each wbBook In Workbooks
        If Windows(wbBook.Name).Visible Then
            If wbBook.Name = wbName Then IsBookOpen = True: Exit For
        End If
    Next wbBook
End Function

let
//получаем исходный текст страницы в виде разбитого на строки текста
    Source = Table.FromColumns({Lines.FromBinary(Web.Contents("https://data.gov.ru/opendata/7708660670-proizvcalendar"))}),
    //отбираем из строк ту, которая содержит внутри текст "Гиперссылка (URL) на набор" и ".csv" и превращаем все это в строку
    //  т.к. изначально Table.SelectRows возвращает набор в виде таблицы
    CsvURLText = Table.SelectRows(Source, each Text.Contains([Column1], "Гиперссылка (URL) на набор") and Text.Contains([Column1], ".csv")){0}[Column1],
    //ищем начало гиперссылки
    url_start_pos = Text.PositionOf(CsvURLText,"http"),
    //ищем конец гиперссылки
    url_end_pos = Text.PositionOf(CsvURLText,".csv"),
    //формируем гиперссылку из CsvURLText
    url = Text.Middle(CsvURLText,url_start_pos,url_end_pos-url_start_pos+4),
    //скачиваем файл CSV по сформированной гиперссылке и открываем его
    //в заголовках будут имена месяцев
    csvfile = Table.PromoteHeaders(Csv.Document(Web.Contents(url),[Delimiter=",", Columns=18, Encoding=65001, QuoteStyle=QuoteStyle.None]), [PromoteAllScalars=true]),
    //сворачиваем столбцы с датами в два столбца: название месяца("Атрибут") и перечень дат("Значение")
    #"Несвернутые столбцы" = Table.UnpivotOtherColumns(csvfile, {"Год/Месяц", "Всего рабочих дней", "Всего праздничных и выходных дней", "Количество рабочих часов при 40-часовой рабочей неделе", "Количество рабочих часов при 36-часовой рабочей неделе", "Количество рабочих часов при 24-часовой рабочей неделе"}, "Атрибут", "Значение"),
    //убираем символы +, которыми обозначаются перенесенные праздничные дни
    #"Замененное значение1" = Table.ReplaceValue(#"Несвернутые столбцы","+","",Replacer.ReplaceText,{"Значение"}),
    //разбиваем столбец с днями на отдельные столбцы
    #"Разделить столбец по разделителю" = Table.SplitColumn(#"Замененное значение1", "Значение", Splitter.SplitTextByDelimiter(",", QuoteStyle.Csv), {"Значение.1", "Значение.2", "Значение.3", "Значение.4", "Значение.5", "Значение.6", "Значение.7", "Значение.8", "Значение.9", "Значение.10", "Значение.11", "Значение.12", "Значение.13", "Значение.14", "Значение.15", "Значение.16"}),
    //сворачиваем все столбцы с днями в два: "Атрибут.1"(нам не нужен) и день("Значение")
    #"Другие столбцы с отмененным свертыванием" = Table.UnpivotOtherColumns(#"Разделить столбец по разделителю", {"Год/Месяц", "Всего рабочих дней", "Всего праздничных и выходных дней", "Количество рабочих часов при 40-часовой рабочей неделе", "Количество рабочих часов при 36-часовой рабочей неделе", "Количество рабочих часов при 24-часовой рабочей неделе", "Атрибут"}, "Атрибут.1", "Значение"),
    //удаляем все строки с сокращенными днями
    #"Строки с примененным фильтром" = Table.SelectRows(#"Другие столбцы с отмененным свертыванием", each not Text.Contains([Значение], "*")),
    //в отдельном столбце формируем из столбцов с годом, месяцем и днем дату
    #"Добавлен пользовательский объект" = Table.AddColumn(#"Строки с примененным фильтром", "Пользовательский", each Date.FromText([Значение] & " " & [Атрибут] & " " & [#"Год/Месяц"],"Ru-ru")),
    //переименовываем столбец
    #"Переименованные столбцы" = Table.RenameColumns(#"Добавлен пользовательский объект",{{"Пользовательский", "Дата"}}),
    //удаляем лишние столбцы(по сути все, кроме столбца дата)
    #"Другие удаленные столбцы" = Table.SelectColumns(#"Переименованные столбцы",{"Дата"}),
    //преобразуем тип Any(Любой) в тип Дата
    #"Измененный тип" = Table.TransformColumnTypes(#"Другие удаленные столбцы",{{"Дата", type date}})
in
    #"Измененный тип"