Календарь красить дни

Option Explicit
 
Private ws     As Worksheet
Private Диап_Календ As Range
Private Диап_Дат As Range
Private Столб_Цвет_Смещ As Long
Private Дата_Текущ As Range
 
Private bDeBug As Boolean
 
Public Sub Календарь_Красить()
    ' Пройтись по списку дат и цветов,
    ' заодно раскрасить заранее заготолвенный календарь
 
    bDeBug = fasle
 
    Список_Проход _
            Выходные( _
            Инит)
End Sub
 
 
Private Function Список_Проход(Optional ByVal msg As Variant) _
        As Variant
 
    Dim el     As Range
 
    For Each el In Диап_Дат
 
        Set Дата_Текущ = el
 
        День_Цвет el
 
    Next
End Function
 
Private Function День_Цвет(el As Range) As Variant
 
    Цвет _
            День( _
            Месяц_Диап( _
            Месяц(el)))
 
End Function
 
Private Function День(ByVal rng As Range) As Range
 
    Dim el As Range, ДеньД As Long
 
    For Each el In rng
 
        ДеньД = День_из_Даты
 
        If bDeBug Then el.Select
 
        If el.Value = ДеньД Then
 
            Set День = el
 
            Exit For
        End If
    Next
End Function
 
Private Function День_из_Даты(Optional ByVal msg As Variant) As Long
 
    День_из_Даты = Format(Дата_Текущ.Value, "d")
 
End Function
 
Private Function Цвет(el As Range) As Variant
 
    el.Interior.Color = _
    Дата_Текущ.Offset(0, Столб_Цвет_Смещ).Interior.Color
 
End Function
 
Private Function Месяц(ByVal el As Range) As String
 
    Месяц = Format(el.Value, "MMMM")
 
End Function
 
Private Function Месяц_Диап(ByVal str As String) As Range
 
    Dim el     As Range
 
    For Each el In Диап_Календ
 
        If InStr(1, el.Value, str, vbTextCompare) > 0 Then
 
            Set Месяц_Диап = Диап_Месяц(el)
 
            Exit For
 
        End If
    Next
End Function
 
Private Function Диап_Месяц(ByVal el As Range) As Range
 
    Set Диап_Месяц = el.Resize(6, 7).Offset(2, 0)
 
End Function
 
Sub tmonth_test()
    Dim y      As Long
    For y = 1 To 12
 
Debug.Print Choose(y, _
                   "Январь", "Февраль", "Март", "Апрель", "Май", "Июнь", _
                   "Июль", "Август", "Сентябрь", "Октябрь", "Ноябрь", "Декабрь")
    Next
End Sub
 
Private Function Выходные(Optional ByVal msg As Variant) As Variant
 
    Dim y      As Long
 
    For y = 1 To 12
 
        Выходные_Красить _
                Выходные_Диап( _
                Месяц_Название_из_Номера(y))
    Next
 
End Function
 
Private Function Выходные_Красить(rng As Range) As Variant
 
    If Not rng Is Nothing Then _
       rng.Interior.ColorIndex = 15
 
End Function
 
Private Function Месяц_Название_из_Номера(ByVal iNumb As Long) _
        As String
 
    Месяц_Название_из_Номера = _
    Array("Январь", "Февраль", "Март", _
          "Апрель", "Май", "Июнь", "Июль", "Август", "Сентябрь", _
          "Октябрь", "Ноябрь", "Декабрь")(iNumb - 1)
 
End Function
 
Private Function Выходные_Диап(ByVal Мес As String) As Range
 
    Dim el As Range, rng_Мес As Range
 
    For Each el In Диап_Календ
 
        If InStr(el.Value, Мес) > 0 Then
 
            Set rng_Мес = Диап_Месяц(el)
 
            Set Выходные_Диап = _
            rng_Мес.Resize(rng_Мес.Rows.Count + 1, 2). _
                                Offset(-1, 5)
 
            Exit For
        End If
    Next
End Function
 
Private Function Инит(Optional ByVal msg As Variant) As Variant
 
    Set ws = Me
 
    With ws
 
        Set Диап_Календ = .Range(.Cells(3, 1), .Cells(27, 33))
 
        Заливки_НЕТ Диап_Календ
 
        Set Диап_Дат = _
        .Range(.Cells(2, 44), .Cells(.Rows.Count, 44).End(xlUp))
 
        Столб_Цвет_Смещ = 2
    End With
End Function
 
Public Sub Заливки_НЕТ(rng As Range)
 
    With rng.Interior
 
        .Pattern = xlNone
 
        .TintAndShade = 0
 
        .PatternTintAndShade = 0
 
    End With
End Sub