【VBA】イナズマ線を描画する

途中で飽きてしまって、エラーチェックも中途半端でコードも美しくなくて気に入らないけど、取りあえず公開します。
気が向いたらリファクタリングするけど、今のコードでも引ける。

Option Explicit

'カレンダー先頭
Public Const CalenderStartAddress As String = "F6"
'データ開始行
Public Const DataStartRow As Integer = 8
'マスタスケジュールワークシート
Public Const MasterSheetName As String = "マスタスケジュール"
'基点日アドレス
Public Const BaseDateAddress As String = "C3"

Public Enum eCol
    Blank1 = 1
    Taskstart
    Taskend
    Progress
    Blank2
End Enum

Option Explicit

Private InazumaSheet As Worksheet    'ワークシートオブジェクト
Private baseDate As Date             '基準日
Private axis() As Variant            '描画する座標
Private rngCalender As Range         'カレンダー領域
Private rngTaskDate As Range         'タスク開始・終了日領域
Private nowXAxis As Single           '現在位置のX軸
Private nowYAxis As Single           '現在位置のY軸

'---------------------------------------------------------------------------------------------------
'【処 理 名】稲妻
'【処理概要】イナズマ線を引く
'【引    数】なし
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Public Sub 稲妻()
    '初期化
    Call init
    '入力チェック
    If Not check Then
        GoTo LBL_TERM
    End If
    'カレンダー領域取得
    Call getCalenderRange
    
    '現在時点座標取得
    Call getNowPoint(rngCalender)
    
    'タスクの座標取得
    Call getTaskInfo
    
    'イナズマ線描画
    Call drawInazumaLine
    
LBL_TERM:
    '終期処理
    Call term
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】初期処理
'【処理概要】初期処理
'【引    数】なし
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub init()
    'ワークシートオブジェクト取得
    Set InazumaSheet = ThisWorkbook.Worksheets(MasterSheetName)
    '基準日取得
    baseDate = InazumaSheet.Range(BaseDateAddress).Value
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】終期処理
'【処理概要】終期処理
'【引    数】なし
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub term()
    Set InazumaSheet = Nothing
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】入力チェック
'【処理概要】入力チェックを実施する
'【引    数】なし
'【返 却 値】True     エラーなし
'            False    エラーあり
'---------------------------------------------------------------------------------------------------
Private Function check() As Boolean
    If InazumaSheet.Range(BaseDateAddress).Value = "" Then
        MsgBox "基点日を入力してください。"
        GoTo LBL_ERROR
    End If
    
    If Not IsDate(InazumaSheet.Range(BaseDateAddress).Value) Then
        MsgBox "基点日に日付を入力してください。"
        GoTo LBL_ERROR
    End If
    
    check = True
    Exit Function
    
LBL_ERROR:
    check = False
    Exit Function
End Function

'---------------------------------------------------------------------------------------------------
'【処 理 名】カレンダー領域取得
'【処理概要】カレンダー領域を取得する
'【引    数】なし
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub getCalenderRange()
    Dim rowIndex As Integer
    Dim endCol As Integer
    
    '行インデックス
    rowIndex = InazumaSheet.Range(CalenderStartAddress).Row
    '列インデックス
    endCol = InazumaSheet.Cells(rowIndex, Columns.Count).End(xlToLeft).Column
    'カレンダー領域取得
    Set rngCalender = InazumaSheet.Range(CalenderStartAddress, _
        InazumaSheet.Cells(rowIndex, endCol))
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】現在時点座標取得
'【処理概要】カレンダーの中から、現在時点を取得する
'【引    数】ByVal rngCalender As Range    カレンダー領域
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub getNowPoint(ByVal rngCalender As Range)
    Dim rng As Range                 '作業領域
    Dim baseDateSerial As Variant    '基準日
    Dim baseDay As Integer           '基準日の日付
    Dim lastDay As Date
    
    '基準日
    baseDateSerial = DateSerial(Year(baseDate), Month(baseDate), 1)
    '基準日の次の最終日
    lastDay = DateSerial(Year(baseDate), Month(baseDate) + 1, 0)
    '基準日の日付
    baseDay = Day(baseDate)
    
    'カレンダーから基準日の年月を探す
    For Each rng In rngCalender
        'マージされている先頭セル以外はスキップ
        If rng.Address <> rng.MergeArea(1).Address Then GoTo LBL_NEXT
        
        '基準日と同じ月の場合
        If DateSerial(Year(rng.Value), Month(rng.Value), 1) = baseDateSerial Then
            '基準日のX軸を取得
            nowXAxis = rng.Left + ((rng.Width / Day(lastDay)) * baseDay)
            '基準日のY軸を取得
            nowYAxis = rng.Top
            Exit For
        End If
LBL_NEXT:
    Next
    
     '描画軸配列へ格納する
     ReDim axis(1, 0)
     axis(0, 0) = nowXAxis
     axis(1, 0) = nowYAxis
     
     Call setAxis(nowXAxis, nowYAxis + rng.Height)
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】タスク座標取得
'【処理概要】タスクの座標を取得する
'【引    数】なし
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub getTaskInfo()
    Dim endRow As Long
    Dim rowIndex As Long
    
    endRow = InazumaSheet.Cells(Rows.Count, eCol.Taskstart).End(xlUp).Row
    For rowIndex = DataStartRow To endRow
        Call getTaskAxis(rowIndex)
    Next
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】座標取得
'【処理概要】座標を取得する
'【引    数】ByVal rowIndex As Long
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub getTaskAxis(ByVal rowIndex As Long)
    Dim startDate As Date
    Dim endDate As Date
    Dim rng As Range            '作業領域
    Dim startAxis As Single
    Dim endAxis As Single
    Dim progressAxis As Single
    Dim yAxis As Single
    Dim cellHeight As Single    'セル高さ
    
    '開始日
    startDate = InazumaSheet.Cells(rowIndex, eCol.Taskstart)
    '終了日
    endDate = InazumaSheet.Cells(rowIndex, eCol.Taskend)
    'Y軸を取得
    yAxis = InazumaSheet.Cells(rowIndex, eCol.Taskstart).Top
    'セルの高さを取得
    cellHeight = InazumaSheet.Cells(rowIndex, eCol.Taskstart).Height
    
    For Each rng In rngCalender
        'マージされている先頭セル以外はスキップ
        If rng.Address <> rng.MergeArea(1).Address Then GoTo LBL_NEXT
        
        '-------------------------------------------------------------------------------
        ' 開始日の座標を取得する
        '-------------------------------------------------------------------------------
        If isInTerm(rng, startDate) Then
            startAxis = getAxis(startDate, rng)
        End If
        '-------------------------------------------------------------------------------
        ' 完了日の座標を取得する
        '-------------------------------------------------------------------------------
        If isInTerm(rng, endDate) Then
            endAxis = getAxis(endDate, rng)
            Exit For
        End If
LBL_NEXT:
    Next
    
    '-------------------------------------------------------------------------------
    ' 進捗の座標を取得する
    '-------------------------------------------------------------------------------
    If InazumaSheet.Cells(rowIndex, eCol.Progress) = 1 Then
        progressAxis = nowXAxis
    Else
        progressAxis = startAxis + ((endAxis - startAxis) * InazumaSheet.Cells(rowIndex, eCol.Progress))
    End If
    
    '開始点
    Call setAxis(nowXAxis, yAxis)
    '進捗点
    Call setAxis(progressAxis, yAxis + (cellHeight / 2))
    '終点
    Call setAxis(nowXAxis, yAxis + cellHeight)
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】座標軸取得
'【処理概要】座標軸を取得する
'【引    数】ByVal targetDate As Date
'            ByVal rng As Range
'【返 却 値】座標
'---------------------------------------------------------------------------------------------------
Function getAxis(ByVal targetDate As Date, ByVal rng As Range) As Single
    Dim lastDay As Date  '該当月の最終日
    
    '対象年月日の月の最終日
    lastDay = DateSerial(Year(targetDate), Month(targetDate) + 1, 0)
    'X軸取得
    getAxis = rng.Left + ((rng.Width / Day(lastDay)) * Day(targetDate))
End Function

'---------------------------------------------------------------------------------------------------
'【処 理 名】期間内比較
'【処理概要】同じ月であるか比較する
'【引    数】ByVal rng As Range
'            ByVal targetDate As Date
'【返 却 値】True     エラーなし
'            False    エラーあり
'---------------------------------------------------------------------------------------------------
Private Function isInTerm(ByVal rng As Range, ByVal targetDate As Date) As Boolean
    Dim tergetSerialDate As Date
    
    tergetSerialDate = DateSerial(Year(targetDate), Month(targetDate), 1)
    isInTerm = False
    If DateSerial(Year(rng.Value), Month(rng.Value), 1) = tergetSerialDate Then
        isInTerm = True
    End If
End Function

'---------------------------------------------------------------------------------------------------
'【処 理 名】座標配列へ格納
'【処理概要】座標配列に描画点の座標を格納する
'【引    数】ByVal xAxis As Single
'            ByVal yAxis As Single
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub setAxis(ByVal xAxis As Single, ByVal yAxis As Single)
    Dim elemIndex As Long            '座標配列の要素数
    
    elemIndex = UBound(axis, 2) + 1
    ReDim Preserve axis(1, elemIndex)
    
    axis(0, elemIndex) = xAxis
    axis(1, elemIndex) = yAxis
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】イナズマ線描画
'【処理概要】イナズマ線を描画する
'【引    数】なし
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub drawInazumaLine()
    Dim index As Long
    
    '描画
    With InazumaSheet.Shapes.BuildFreeform(msoEditingCorner, axis(0, 0), axis(1, 0))
        For index = 1 To UBound(axis, 2)
            .AddNodes msoSegmentCurve, msoEditingCorner, axis(0, index), axis(1, index)
        Next
        With .ConvertToShape
            .Line.Weight = 1.5
            .Line.ForeColor.RGB = RGB(255, 0, 0)
        End With
    End With
End Sub