Microsoft Excel:

  Таблицы и VBA. Справочник.
  Вопросы и Ответы. Советы. Примеры.
Меню Заметки | VBA : Календарь с использованием ячеек рабочего листа


Rambler's Top100


Counter CO.KZ

Вариантов программного создания собственного календаря много, но если Вы выбрали 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



    Автор : Климов Павел Юрьевич
    © 2004-2016 Климов П.Ю. Все права защищены. WebDesign & Error's Klimoff