カレンダーを作成するマクロをクラスモジュールに移植する

昨日は、一括で作成した複数月のカレンダーについて、良い感じの位置とズームで表示させてみた。
infoment.hatenablog.com
今日は、最近では恒例の「作成したものをクラスモジュールにしたら」に挑戦する。
f:id:Infoment:20190306223012p:plain

毎度の話だが、別に無理にクラスモジュールにする必要は無い。
「もしも作成したマクロが、クラスモジュールだったら」
程度の参考情報。往年のドリフターズのコントを見るつもりで眺めてほしい。
では、いってみよう。

クラスモジュール（CalendarClass）

複数個所に登場していたtarget_rangeは、最初にPublic変数で取得させている。

Option Explicit

Public Enum ZoomType
    RowFit
    CollumnFit
    AllFit
End Enum

Public target_range As Range

Function GetUpperLeftCell(zoom_range As Range) As Range
    Dim dr As Long
        If zoom_range.Cells(1, 1).Row = 1 Then
            dr = 1
        Else
            dr = zoom_range.Cells(1, 1).Row - 1
        End If

    Dim dc As Long
        If zoom_range.Cells(1, 1).Column = 1 Then
            dc = 1
        Else
            dc = zoom_range.Cells(1, 1).Column - 1
        End If

    Set GetUpperLeftCell = Cells(dr, dc)
End Function

Sub ZoomFit(zoom_range As Range, _
            Optional zoom_type As ZoomType = CollumnFit, _
            Optional zoom_ratio As Double = 1)
            
    
    ' フィットさせたい範囲の左上セル。
    Dim UpperLeftCell As Range
    Set UpperLeftCell = GetUpperLeftCell(zoom_range)
    
    'Gotoメソッドで、当該セルを画面の左上に表示させる。
    Application.Goto UpperLeftCell, True

    ' フィットさせたい範囲の右下セル。
    ' ※余白用にオフセットさせている。
    Dim BottomRightCell As Range
    Set BottomRightCell = zoom_range.SpecialCells(xlCellTypeLastCell).Offset(1, 1)

    Dim myRng As Range
    Set myRng = Range(UpperLeftCell, BottomRightCell)
        Select Case zoom_type
            Case ZoomType.AllFit
                myRng.Select
            Case ZoomType.CollumnFit
                myRng.Rows(1).Select
            Case ZoomType.RowFit
                myRng.Columns(1).Select
        End Select
        
        ActiveWindow.Zoom = True
        UpperLeftCell.Select
        ActiveWindow.Zoom = ActiveWindow.Zoom * zoom_ratio
End Sub

Sub MakeSingleCalendar()
    ' 選択範囲判定。
    ' 複数セルが選択されている場合、処理を終了する。
    If target_range.Count > 1 Then
        Exit Sub
    ' 入力値が日付でない場合、処理を終了する。
    ElseIf IsDate(target_range) = False Then
        Exit Sub
    Else
        ' 選択セルに入力されている日付を取得する。
        Dim TargetDate As Date
            TargetDate = target_range.Value
    End If
    
    ' 選択セルを基準に、カレンダーの開始セルを取得する。
    Dim StartRange As Range
    ' 選択セルの日付が当月第何週かを求め、上方向のオフセット量を求める。
    Dim dr As Long
        If Day(TargetDate) = 1 Then
            dr = 1
        Else
            dr = WorksheetFunction.WeekNum(TargetDate) - _
                 WorksheetFunction.WeekNum(TargetDate - Day(TargetDate)) _
                 + 1
        End If
        
    ' 選択セルの日付が何曜日かを求め、左方向のオフセット量を求める。
    Dim dc As Long
        dc = WorksheetFunction.Weekday(TargetDate) - 1

    Set StartRange = target_range.Offset(-dr, -dc)
        StartRange.Value = TargetDate - dc - 7 * dr
    
    ' カレンダーの範囲を、７行×７列とする。
    ' 一行目は、曜日ラベルに使用する。
    Dim CalendarRange As Range
    Set CalendarRange = StartRange.Resize(7, 7)
    
    With CalendarRange
        ' 計算式で日付を入力。
        .Cells(2, 1).Resize(6) = "=R[-1]C+7"
        .Columns("B:G") = "=RC[-1]+1"
        ' 一行目を、書式設定で曜日に変更。
        .Rows(1).NumberFormatLocal = "aaa"
        .HorizontalAlignment = xlCenter
        
        ' 以降、条件付き書式で色付けする。
        .FormatConditions.Delete
        ' 当月でないセルは灰色に塗りつぶす。
        With .Rows("2:7")
            .NumberFormatLocal = "d"
            .FormatConditions.Add Type:=xlExpression, _
                                  Formula1:="=MONTH(" & .Range("A1").Address(0, 0) & ")<>" & _
                                            "MONTH(" & .Range("A1").Offset(-3).Address(True, True) & ")"
            With .FormatConditions(1).Interior
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorDark1
                .TintAndShade = -0.14996795556505
            End With
            .FormatConditions(1).StopIfTrue = False
        End With

        ' 日曜日は、文字色を赤にする。
        .FormatConditions.Add Type:=xlExpression, _
                              Formula1:="=WEEKDAY(" & StartRange.Address(0, 0) & ")=1"
        .FormatConditions(2).Font.Color = -16777024
        
        ' 土曜日は、文字色を碧にする。
        .FormatConditions.Add Type:=xlExpression, _
                              Formula1:="=WEEKDAY(" & StartRange.Address(0, 0) & ")=7"
        .FormatConditions(3).Font.ThemeColor = xlThemeColorAccent1
    End With
    
    ' yyyy年mm月を追記。
    With StartRange.Offset(-2)
        .Value = Format(TargetDate, "yyyy年mm月")
        .Resize(, 4).Merge
        .HorizontalAlignment = xlLeft
    End With
    
End Sub

Sub MakeCalendar(calendar_count As Long, column_count As Long)
    MakeSingleCalendar
    Dim i As Long
    If calendar_count >= 2 Then
        For i = 2 To calendar_count
            ' 翌月１日を求める。
            Dim YearMonthRange As Range
            Set YearMonthRange = target_range.CurrentRegion.Cells(-1, 1)
            Dim NextMonth As Date
                NextMonth = WorksheetFunction.EDate(YearMonthRange, 1)
            
            ' 翌月１日の、カレンダー左端からの「ずれ」量を求める。
            Dim dc As Long
                dc = WorksheetFunction.Weekday(NextMonth)
            
            ' 翌月の年月表示セルを求める
            Dim NextYearMonthRange As Range
            
            ' カレンダーの行列で、翌月の位置を決定する。
            ' 「改行」するか否かは、周期（column_count）の１番目か否かで判定する。
            ' １番目か否かは、割り算の余りで求めている。
            
            ' 列数のオフセット量は、「yyyy年mm月」が4つのセルを
            ' 結合していることを加味している。
            If i Mod column_count = 1 Then
                Set NextYearMonthRange = YearMonthRange.Offset(11, -8 * (column_count - 1) - 1)
            Else
                Set NextYearMonthRange = YearMonthRange.Offset(, 4)
            End If
        
            Set target_range = NextYearMonthRange.Offset(3, dc)
                target_range.Value = NextMonth
            MakeSingleCalendar
        Next
    End If
End Sub

例によって標準モジュール側は、実に閑散とした状態になった。

標準モジュール

Sub test()
    With Range("H20")
        .NumberFormatLocal = "d"
        .Value = "4/1"
    End With
    
    Dim CC As CalendarClass
    Set CC = New CalendarClass
    Set CC.target_range = Range("H20")
    
    CC.MakeCalendar calendar_count:=12, _
                    column_count:=3
    
    ActiveSheet.UsedRange.EntireColumn.AutoFit
    
    CC.ZoomFit zoom_range:=ActiveSheet.UsedRange, _
               zoom_type:=RowFit, _
               zoom_ratio:=0.9
End Sub