'
' 月間シート作成マクロ
' Date: 1996/05/01  Author: Kazuyuki Housaka
'
'新規ワークシートでSheetInit()を実行してください。
'
Option Explicit
'
' 変更可能な定数−始め
Const DateCell = "A1"
Const StartCell = "A1"
Const DateCellFormat = "yy""年""m""月"""
Const RowCount = 10
Const FirstColumnWidth = 10
Const DayColumnWidth = 2.6
Const DateRowHeight = 12
Const WeekRowHeight = 12
Const BodyRowHeight = 30
' 変更可能な定数−終わり

Sub SheetInit()
    Dim day1 As Date, day2 As Date
    Dim wek1 As Integer
    Dim i As Integer
    Dim rng0 As Range
    Dim rng1 As Range
    Dim ret

    ret = MsgBox(DateCell & "の日付を基にシートを初期化します。" & Chr(10) & _
        "日付・曜日の行およびシート全体の罫線は変更されます。" & Chr(10) & _
        "続行しますか？", vbYesNo + vbExclamation, "月間シートの初期化")
    If ret = vbNo Then Exit Sub

    'プロシージャが終了するまで表示の更新をしない
    Application.ScreenUpdating = False

    Set rng0 = Range(StartCell)

    ' DateCellに月の１日の日付を代入する
    With Range(DateCell)
        .NumberFormat = DateCellFormat
        If IsDate(.Value) Then
            day1 = .Value
        Else
            day1 = Date
        End If
        day1 = DateSerial(Year(day1), Month(day1), 1)
        .Value = day1
    End With

    ' １日の曜日を調べる
    wek1 = WeekDay(day1)
    If wek1 = 7 Then
        Set rng1 = rng0.Cells(1, 2)
    Else
        Set rng1 = rng0.Cells(1, 2 + wek1)
    End If

    ' 日付と曜日の行をクリアする
    rng0.Cells(1, 2).Resize(2, 37).Clear

    ' 日付と曜日の行の書式を設定する
    HeaderFormatSet

    ' 月の最終日を調べる
    day2 = DateSerial(Year(day1 + 31), Month(day1 + 31), 1)

    ' 日付をセルに代入する
    For i = 1 To Day(day2 - 1)
        rng1.Cells(1, i).Value = DateSerial(Year(day1), Month(day1), i)
    Next

    ' 土日の列に塗り潰しパターンを設定する
    i = RowCount + 2
    HolidayFormatSet Union( _
      rng0.Cells(1, 2).Resize(i, 2), rng0.Cells(1, 9).Resize(i, 2), _
      rng0.Cells(1, 16).Resize(i, 2), rng0.Cells(1, 23).Resize(i, 2), _
      rng0.Cells(1, 30).Resize(i, 2), rng0.Cells(1, 37).Resize(i, 2))

    ' セルの幅と高さを設定する
    rng0.Cells(1, 1).ColumnWidth = FirstColumnWidth
    rng0.Cells(1, 2).Resize(1, 37).ColumnWidth = DayColumnWidth
    rng0.Cells(1, 1).RowHeight = DateRowHeight
    rng0.Cells(2, 1).RowHeight = WeekRowHeight
    rng0.Cells(3, 1).Resize(RowCount, 1).RowHeight = BodyRowHeight

    ' 罫線を設定する
    BorderSet1 rng0.Resize(RowCount + 2, 38)

    'ウィンドウのズームを設定する
    Range("A1").CurrentRegion.Resize(RowCount + 2).Select
    ActiveWindow.Zoom = True
    Range("A1").Select

    'ページレイアウトの設定
    ' PageSetUp1

End Sub

' 日付と曜日の行の書式を設定する（変更可）

Sub HeaderFormatSet()
    Dim i As Integer
    Application.ScreenUpdating = False

    With Range(StartCell)

        ' 日付行の書式を設定する
        With .Cells(1, 2).Resize(1, 37)
            .NumberFormat = "d"
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = xlHorizontal
            .AddIndent = False
            With .Font
                .Name = "ＭＳ 明朝"
                .FontStyle = "標準"
                .Size = 8
                .Strikethrough = False
                .Superscript = False
                .Subscript = False
                .OutlineFont = False
                .Shadow = False
                .Underline = xlNone
                .ColorIndex = xlAutomatic
            End With
        End With

        ' 曜日の行の書式を設定する
        With .Cells(2, 2).Resize(1, 37)
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = xlHorizontal
            .AddIndent = False
            With .Font
                .Name = "ＭＳ 明朝"
                .FontStyle = "標準"
                .Size = 8
                .Strikethrough = False
                .Superscript = False
                .Subscript = False
                .OutlineFont = False
                .Shadow = False
                .Underline = xlNone
                .ColorIndex = xlAutomatic
            End With
        End With

        ' 曜日をセルに代入する
        With .Cells(2, 2)
            For i = 0 To 4
                With .Cells(1, i * 7 + 1)
                    .Cells(1, 1).Value = "土"
                    .Cells(1, 2).Value = "日"
                    .Cells(1, 3).Value = "月"
                    .Cells(1, 4).Value = "火"
                    .Cells(1, 5).Value = "水"
                    .Cells(1, 6).Value = "木"
                    .Cells(1, 7).Value = "金"
                End With
            Next
            .Cells(1, 5 * 7 + 1).Value = "土"
            .Cells(1, 5 * 7 + 2).Value = "日"
        End With
    End With
End Sub

' 土日の塗り潰しパターンを設定する（変更可）
Sub HolidayFormatSet(rangeRef As Range)
    If TypeName(rangeRef) <> "Range" Then Exit Sub
    With rangeRef.Interior
        .ColorIndex = 40
        .Pattern = xlSolid
        .PatternColorIndex = 2
    End With
End Sub

' 罫線を設定する（変更可）
Sub BorderSet1(rangeRef As Range)
   With rangeRef
        With .Borders(xlLeft)
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlRight)
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlTop)
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlBottom)
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        .BorderAround Weight:=xlThin, ColorIndex:=xlAutomatic
    End With
End Sub

' 選択列に休日書式を設定する
Sub SelectionHolidayFormatSet()
    Dim rng1 As Range
    If TypeName(Selection) <> "Range" Then End
    Application.ScreenUpdating = False
    Set rng1 = Intersect(Range(StartCell).Cells(1, 2).Resize(RowCount + 2, 37), _
     Selection.EntireColumn)
    If TypeName(rng1) <> "Range" Then Exit Sub
    HolidayFormatSet rng1
End Sub

' 選択列の休日書式をクリアする（変更可）
Sub SelectionHolidayFormatClear()
    Dim rng1 As Range
    If TypeName(Selection) <> "Range" Then End
    Application.ScreenUpdating = False
    Set rng1 = Intersect(Range(StartCell).Cells(1, 2).Resize(RowCount + 2, 37), _
      Selection.EntireColumn)
    If TypeName(rng1) <> "Range" Then Exit Sub
    With rng1.Interior
        .ColorIndex = xlNone
        .Pattern = xlNone
        .PatternColorIndex = xlNone
    End With
End Sub