Microsoft Excel | Заметки | VBA : Календарь с использованием ячеек рабочего листа

Microsoft Excel:

Таблицы и VBA. Справочник.
Вопросы и Ответы. Советы. Примеры.

Меню Заметки | VBA : Календарь с использованием ячеек рабочего листа

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

т.е. :

Откройте рабочую книгу, в которой Вы предполагаете создать календарь

Активируйте нужный рабочий лист

Выберите диапазон ячеек, состоящий из 42 ячеек = 6 строк X 7 столбцов
(при желании можно добавить заголовок(шапку), содержащий перечень всех дней недели)

Присвойте этому диапазону имя, например, Календарь (этот пункт не является обязательным, т.е. в нижеопубликованном макросе, вместо Range("Календарь") можно использовать Range("B3:H8") или [B3:H8], однако, этот финт позволит избежать проблем, если удаление/добавление ячеек, вызовет изменение адресации)

Выберите ячейку, в которой в дальнейшем будет выбираться месяц

Присвойте этой ячейке имя, например, Месяц (этот пункт также не является обязательным, см.выше)

В меню Данные выберите команду Проверка и в появившемся стандартном диалоговом окне Проверка вводимых значений, в поле со списком Тип данных: выберите Список, а в текстовом поле Источник: введите (или вставьте предварительно скопированный) нижеприведённый текст

Январь;Февраль;Март;Апрель;Май;Июнь;Июль; Август;Сентябрь;Октябрь;Ноябрь;Декабрь

Выберите ячейку, в которой будет выбираться год

Присвойте этой ячейке имя, например, Год (и этот пункт тоже можно пропустить, см.выше)

В меню Данные выберите команду Проверка и в появившемся стандартном диалоговом окне Проверка вводимых значений, в поле со списком Тип данных: выберите Список, а в текстовом поле Источник: введите необходимые года (не забывая, что максимально допустимое количество символов, включая разделители, составляет 255)

В меню Вставка выберите пункт Имя и команду Присводить. В появившемся стандартном диалоговом окне Присвоение имени, текстовом поле Имя: введите Список, а в текстовом поле Формула: введите, а лучше, вставьте предварительно скопированный нижеприведённый текст

={"Январь";"Февраль";"Март";"Апрель";"Май";"Июнь";"Июль"; "Август";"Сентябрь";"Октябрь";"Ноябрь";"Декабрь"}

Комментарий : На самом деле, создание именованной формулы также не является обязательным условием, ибо определить номер месяца, исходя из его названия можно, например, так :

iMonth = Application.Match([Месяц].Value, Array( _
"Январь", "Февраль", "Март", "Апрель", "Май", "Июнь", _
"Июль", "Август", "Сентябрь", "Октябрь", "Ноябрь", "Декабрь"), 0)

Или так, если у Вас установлен руссифицированный офис :

iMonth = Application.Match([Месяц], Application.GetCustomListContents(4), 0)

Или даже так, при условии, что у Вас установлен Microsoft Excel 2000 (или старше) :

iMonth = Application.Match([Месяц], Split([Месяц].Validation.Formula1, ";"), 0)

Впрочем, без программного использования стандартной функции рабочего листа =ПОИСКПОЗ() / Match() мы также можем обойтись, если воспользуемся VB функцией DatePart()

iMonth = DatePart("m", "01-" & [Месяц] & "-" & iYear)

iMonth = DatePart("m", [Месяц] & " " & iYear)

Измените параметры форматирования у ячеек диапазона Календарь, а также Месяц, Год в соответствии со своими требованиями.

Подведите курсор мышки к ярлычку рабочего листа, затем, кликните правой кнопкой мышки, и в появившемся контекстом меню выберите команду Исходный текст (или выберите нужный модуль в редакторе VBA)

Скопируйте в модуль листа нижеопубликованный макрос и сохраните изменения

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    If Not Intersect(Target, [Год, Месяц]) Is Nothing Then
       Dim iYear%, iMonth%, iDay%, iOffset%, iCount%
       Dim iMin As Date, iMax As Date, iArrDays(5, 6)

       iYear = [Год].Value
       iMonth = [Match(Месяц, Список, 0)]
       iMin = DateSerial(iYear, iMonth, 1)
       iMax = DateSerial(iYear, iMonth + 1, 1)
       iOffset = WeekDay(iMin, vbMonday) - 2
       
       For iDay = 1 To iMax - iMin
           iCount = iDay + iOffset
           iArrDays(iCount \ 7, iCount Mod 7) = iDay
       Next
       [Календарь].Value = iArrDays
    End If
End Sub

Примечание : Если же Вам необходимо определить ячейки без дат (пустышки), например, для того, чтобы изменить цвет заливки таких ячеек ( хотя это можно осуществить и с помощью условного форматирования, см. пример#2 ), то :

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    If Not Intersect(Target, [Год, Месяц]) Is Nothing Then
       Dim iYear%, iMonth%, iDay%, iOffset%, iCount%
       Dim iArrDays(5, 6) ' iArrDays(0 To 5, 0 To 6)

       iYear = [Год].Value
       iMonth = [Match(Месяц, Список, 0)]
       iOffset = WeekDay(DateSerial(iYear, iMonth, 1), vbMonday) - 1

       For iCount = 0 To 41
           iDay = iCount - iOffset + 1
           If Month(DateSerial(iYear, iMonth, iDay)) = iMonth Then
              iArrDays(iCount \ 7, iCount Mod 7) = iDay
           'Else
           '   MsgBox "Это - пустышка", , ""
           End If
       Next
       [Календарь].Value = iArrDays
    End If
End Sub

или

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    If Not Intersect(Target, [Год, Месяц]) Is Nothing Then
       Dim iMonth%, iYear%, iCount%, iMin As Date, iDate As Date
       Dim iArrDays(5, 6) ' iArrDays(0 To 5, 0 To 6)

       iYear = [Год].Value
       iMonth = [Match(Месяц, Список, 0)]
       iMin = DateSerial(iYear, iMonth, 1)
       iMin = iMin - WeekDay(iMin, vbMonday) + 1

       For iCount = 0 To 41
           iDate = iMin + iCount
           If Month(iDate) = iMonth Then
              iArrDays(iCount \ 7, iCount Mod 7) = Day(iDate)
           'Else
           '   MsgBox "Это - пустышка", , ""
           End If
       Next
       [Календарь].Value = iArrDays
    End If
End Sub

или

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    If Not Intersect(Target, [Год, Месяц]) Is Nothing Then
       Dim iYear%, iMonth%, iOffset%, iCount%
       Dim iMin As Date, iMax As Date, iDate As Date
       Dim iArrDays(5, 6) ' iArrDays(0 To 5, 0 To 6)

       iYear = [Год].Value
       iMonth = [Match(Месяц, Список, 0)]
       iMin = DateSerial(iYear, iMonth, 1)
       iMax = DateSerial(iYear, iMonth + 1, 1) - 1
       iOffset = WeekDay(iMin, vbMonday) - 1

       For iCount = 0 To 41
           iDate = iMin + iCount - iOffset
           Select Case iDate
               Case iMin To iMax
                  iArrDays(iCount \ 7, iCount Mod 7) = Day(iDate)
               'Case Else
               '   MsgBox "Это - пустышка", , ""
           End Select
       Next
       [Календарь].Value = iArrDays
    End If
End Sub

Теперь, если при открытии книги с календарём Вы разрешите выполнение макросов, и предварительно, не установите высокий уровень безопасности (MS Excel 2000, XP), то после выбора(или ввода) нужного месяца и года в соответствующих ячейках, Вы получите необходимый календарь.

Разумеется, Вы можете изменить и "инструмент" позволяющий выбирать месяц/год, например, использовать для этого родной элемент управления Поле со списком с панели инструментов Формы (см. пример#2), или разместить перечень годов в ячейках рабочего листа и связать выпадающие списки с этими ячейками.

В общем, простор для творчества имеется, от себя лишь добавлю, что если Вам понадобится копировать дату в буфер обмена, например, после двойного клика в соответствующей ячейке календаря, то просто добавьте в модуль листа, ещё одно событие :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
    If Not Intersect(Target, [Календарь]) Is Nothing Then
       Cancel = True
       If Application.IsNumber(Target) = True Then
          Dim iClipboard As New MSForms.DataObject
          iClipboard.SetText DateSerial([Год], [Match(Месяц, Список, 0)], Target), 1
          'iClipboard.SetText Target & "-" & [Месяц] & "-" & [Год], 1
          iClipboard.PutInClipboard
       End If
    End If
End Sub

Автор : Климов Павел Юрьевич

WebDesign & Error's Klimoff

Microsoft Excel:

Таблицы и VBA. Справочник. Вопросы и Ответы. Советы. Примеры.

Таблицы и VBA. Справочник.
Вопросы и Ответы. Советы. Примеры.