カレンダー枠作成 - DrunkBacchus

'カレンダー枠の描画
Sub DrawCalendarFrame()

   Dim DateCol As Long
   Dim EndColumn As Long
   Dim ColumnWeekDay As Integer
   Dim ColumnMonth As Integer
   Dim ColumnDate As Date
   
   Dim RestDaysM As Integer        '月の残り
   Dim RestDaysW As Integer        '週の残り
   Dim ColumnDays As Integer       '列の日数
   
   'ラベル行の設定
   Dim WeekRow As Long
   Dim MonthRow As Long
   Dim DateRow As Long
   Dim TopTitleRow As Long
   Dim ButtomTitleRow As Long

   'セルに記入するラベル
   Dim MonthNo As Integer

   '結合するスタート列
   Dim MonthCol As Long
   Dim WeekCol As Long
   
   '設定値の取得
   StartDate = Range("C2").Value       '開始日
   EndDate = Range("C3").Value         '終了日
   StartColumn = Range("C4").Value     '開始列
   DayWidth = Range("C6").Value        '日幅
   StartDay = Range("C5").Value        '開始曜日
   ShipStartDate = Range("C8").Value   '出荷開始日
   
   WeekRow = 10
   MonthRow = 11
   DateRow = 12
   TopTitleRow = Application.WorksheetFunction. _
       Min(WeekRow, MonthRow, DateRow)
   ButtomTitleRow = Application.WorksheetFunction. _
       Max(WeekRow, MonthRow, DateRow)
   
   '画面更新と警告の停止
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
   
   '既存の枠をクリア
   EndColumn = Cells(DateRow, StartColumn). _
       End(xlToRight).Column
   Range(Cells(TopTitleRow, StartColumn), _
       Cells(ButtomTitleRow, EndColumn)).Clear
   
   '    スタート
   DateCol = StartColumn
   WeekCol = StartColumn
   MonthCol = StartColumn
   ColumnWeekDay = Weekday(StartDate)
   ColumnDate = StartDate
    
   '週番号を記入
   Cells(WeekRow, DateCol).Value = _
       Int((StartDate - ShipStartDate) / 7) + 1
   '月番号を記入
   MonthNo = Month(StartDate)
   Cells(MonthRow, DateCol).Value = MonthNo
   
   Do Until ColumnDate > EndDate
       'Weekの残りを取得
       RestDaysW = _
       (StartDay - ColumnWeekDay + 6) Mod 7 + 1
       '日付を記入
       Cells(DateRow, DateCol).Value = ColumnDate
   
       '月の残り日数を取得
       RestDaysM = DateSerial(Year(ColumnDate), _
       Month(ColumnDate) + 1, 1) - ColumnDate
       
       '週のチェック
   
       'もし､列の曜日が開始曜日と同じであれば
       If ColumnWeekDay = StartDay Then
           '週番号を記入
           Cells(WeekRow, DateCol).Value = _
           Int((ColumnDate - ShipStartDate) / 7) + 1
           '結合スタート列に設定
           WeekCol = DateCol
       '違えば
       Else
           '結合スタート列から現在列までを結合
           Range(Cells(WeekRow, WeekCol), _
           Cells(WeekRow, DateCol)).Merge
       End If
       
       '月のチェック
       'もし､列の月がMonthNoと違っていれば
       If Month(ColumnDate) <> MonthNo Then
           '結合スタート列から､左隣の列までを結合
           Range(Cells(MonthRow, MonthCol), _
           Cells(MonthRow, DateCol - 1)).Merge
           '月番号を変更
           MonthNo = Month(ColumnDate)
           '結合スタート月に設定
           MonthCol = DateCol
           '月番号を記入
           Cells(MonthRow, DateCol).Value = MonthNo
       End If
       
       'もし､月残り日数の方が週残り日数よりも小さい場合は
       If RestDaysM < RestDaysW Then
           Columns(DateCol).ColumnWidth = _
               pWidthToColumnWidth(RestDaysM * DayWidth)
           ColumnWeekDay = ColumnWeekDay + RestDaysM
           ColumnDate = ColumnDate + RestDaysM
       '何もなければ
       Else
           Columns(DateCol).ColumnWidth = _
               pWidthToColumnWidth(RestDaysW * DayWidth)
           ColumnDate = ColumnDate + RestDaysW
           ColumnWeekDay = StartDay
       End If
       '次の列COL = col + 1
       DateCol = DateCol + 1
   Loop
   
   '追加整形
   '最後の月をマージ
   Range(Cells(MonthRow, MonthCol), _
       Cells(MonthRow, DateCol - 1)).Merge
   '最終列を取得
   EndColumn = Cells(DateRow, StartColumn) _
       .End(xlToRight).Column
   'タイトル行の書式設定
   Range(Cells(MonthRow, StartColumn), _
       Cells(MonthRow, EndColumn)).HorizontalAlignment = xlCenter
   Range(Cells(WeekRow, StartColumn), _
       Cells(WeekRow, EndColumn)).HorizontalAlignment = xlCenter
   Range(Cells(DateRow, StartColumn), _
       Cells(DateRow, EndColumn)).HorizontalAlignment = xlLeft
   Range(Cells(DateRow, StartColumn), _
       Cells(DateRow, EndColumn)).NumberFormatLocal = "d"
   Range(Cells(DateRow, StartColumn), _
       Cells(DateRow, EndColumn)).ShrinkToFit = True
   
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
End Sub