作成したカレンダーを、良い感じの位置とズームで表示する

昨日は、日付を入力したセル（１つ）を起点に、複数月を指定した月数で折り返してカレンダーを作成してみた。
infoment.hatenablog.com
しかし実際に作成してみると、画面の外側にはみ出すなどして見難い場合が多く使いにくい。

そこで今回は、作成したカレンダーがバチっと画面内に収まるようにならないか挑戦する。
f:id:Infoment:20190304221643p:plain

今回はまず、以下のような場合を想定してお試し版を作ってみる。
f:id:Infoment:20190304222026p:plain

余白が無いと息苦しいので（※個人的趣味）、一回り大きな範囲（オレンジ色）でフィットさせてみよう。
f:id:Infoment:20190304222243p:plain

まずはフィットさせたい範囲の、さらに左上のセルを取得してみる。
f:id:Infoment:20190304222416p:plain

もともと壁際の場合、それ以上は左または上に行けないので、少々面倒くさい。

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

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

    Set GetUpperLeftCell = Cells(dr, dc)
End Function

次いで、列方向で画面いっぱいにズームするマクロを作成してみる。

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

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

    ' 幅（列方向）を変更する比率。
    Dim WidthRatio As Double
    
    ' 高さ（行方向）を変更する比率。
    ' ※お試し版では使用しない。
    Dim HeightRatio As Double
    
    ' ズーム比率。
    Dim ZoomRatio As Long

    ' 画面に表示されている範囲のうち、一番右下のセル。
    ' ※画面に表示されている範囲は、ActiveWindow.VisibleRangeで取得できる。
    Dim VisibleLastCell As Range
        With ActiveWindow.VisibleRange
            Set VisibleLastCell = .Cells(.Rows.Count, .Columns.Count)
        End With

    ' フィットさせたい範囲の幅。
    Dim TargetRangeWidth As Long
        TargetRangeWidth = BottomRightCell.Left + BottomRightCell.Width - UpperLeftCell.Left
    
    ' フィットさせたい範囲の高さ。
    Dim TargetrangeHeight As Long
        TargetrangeHeight = BottomRightCell.Top + BottomRightCell.Height - UpperLeftCell.Top

    ' 画面に表示されている範囲の幅。
    Dim VisibleRangeWidth As Long
        VisibleRangeWidth = VisibleLastCell.Left + VisibleLastCell.Width - UpperLeftCell.Left
    
    ' 画面に表示されている範囲の高さ。
    Dim VisibleRangeHeight As Long
        VisibleRangeHeight = VisibleLastCell.Top + VisibleLastCell.Height - UpperLeftCell.Top
        
        ' それぞれの幅を比較することで、拡大するか縮小するかを判定。
        If TargetRangeWidth > VisibleRangeWidth Then
            WidthRatio = TargetRangeWidth / VisibleRangeWidth
        Else
            WidthRatio = VisibleRangeWidth / TargetRangeWidth
        End If

        ZoomRatio = ActiveWindow.Zoom * WidthRatio
        
        If ZoomRatio >= 400 Then ZoomRatio = 400
        
        ' ズーム変更。
        ActiveWindow.Zoom = ZoomRatio
End Sub