【簡単エクセル/Excel VBA マクロ】カレンダーを作成する｜アプリ事例 #005【ファイルダウンロード可】

Option Explicit


Sub CreateCalendar()


    ' 変数宣言
    Dim this_wb             As Workbook     ' このワークブック
    Dim this_ws1            As Worksheet    ' this_wb のワークシート1
    Dim new_wb              As Workbook     ' 新しく作成するワークブック
    Dim new_ws1             As Worksheet    ' new_wb のワークシート1
    Dim new_window          As Window       ' new_wb のウィンドウ
    Dim user_input_year     As Long         ' ユーザーが指定した年
    Dim user_input_month    As Long         ' ユーザーが指定した月
    Dim last_day_of_month   As Long         ' ユーザー名が指定した月の最終日
    Dim column_index        As Long         ' 曜日に基づく列インデックス
    Dim row_index           As Long         ' 行インデックス
    Dim day_counter         As Long         ' 日数カウンター
    Dim weekday_name        As String       ' 曜日名
    Dim row_position        As Long         ' 枠線調整のための行の位置
    
    ' 定数設定
    Const START_COLUMN      As Long = 2     ' カレンダーの開始列
    Const START_ROW         As Long = 3     ' カレンダーの開始行
    
    
    ' 現在のワークブックとワークシートを取得
    Set this_wb = ThisWorkbook
    Set this_ws1 = this_wb.Worksheets(1)
    
    ' 新しいカレンダー用のワークブックとワークシートを作成
    Set new_wb = Workbooks.Add
    Set new_ws1 = new_wb.Worksheets(1)
    
    ' カレンダー作成対象の年と月をワークシートから取得
    user_input_year = this_ws1.Cells(17, 4)
    user_input_month = this_ws1.Cells(17, 5)
    
    ' カレンダーのタイトル（年と月）を新しいシートに書き込み
    new_ws1.Cells(START_ROW - 1, START_COLUMN).Value = _
        "'" & user_input_year & "年" & user_input_month & "月"
    
    ' カレンダ作成対象月の最終日を取得
    last_day_of_month = Day( _
        DateSerial(user_input_year, user_input_month + 1, 1) - 1 _
    )
    
    ' 行インデックスの初期化
    row_index = START_ROW
    
    ' 各日付をループ
    For day_counter = 1 To last_day_of_month
    
        ' 曜日名（例: 月、火、水...）を取得
        weekday_name = WeekdayName( _
            Weekday( _
                DateSerial( _
                    user_input_year, user_input_month, day_counter _
                ), vbSunday _
            ), True _
        )
        
        ' 曜日から列インデックスを計算（列の位置を設定）
        column_index = Weekday( _
            DateSerial( _
                user_input_year, user_input_month, day_counter _
            ), vbSunday _
        ) + START_COLUMN - 1
    
        ' 日付と曜日をカレンダーに入力（土曜日は青字、日曜日は赤字で表示）
        With new_ws1.Cells(row_index, column_index)
            .Value = day_counter
            If weekday_name = "土" Then .Font.Color = RGB(0, 112, 192)
            If weekday_name = "日" Then .Font.Color = RGB(192, 0, 0)
        End With
        
        With new_ws1.Cells(row_index + 1, column_index)
            .Value = weekday_name
            If weekday_name = "土" Then .Font.Color = RGB(0, 112, 192)
            If weekday_name = "日" Then .Font.Color = RGB(192, 0, 0)
        End With
        
        ' 日付と曜日のセルを中央寄せに設定
        new_ws1.Range( _
            new_ws1.Cells(row_index, column_index), _
            new_ws1.Cells(row_index + 3, column_index) _
        ).HorizontalAlignment = xlCenter
    
        ' もし土曜日なら次の行インデックスに移動
        If Not day_counter = last_day_of_month Then
            
            If column_index = START_COLUMN + 6 Then
                row_index = row_index + 3
            End If
        
        End If
    
    Next day_counter
     
    ' カレンダー全体に枠線を設定
    new_ws1.Range( _
        new_ws1.Cells(START_ROW, START_COLUMN), _
        new_ws1.Cells(row_index + 2, START_COLUMN + 6) _
    ).Borders.LineStyle = xlContinuous
    
    ' カレンダーの水平枠線の調整
    For row_position = START_ROW To row_index Step 3    ' ３行ごとに処理
        
        ' 日付と曜日の間の枠線を非表示に
        new_ws1.Range( _
            new_ws1.Cells(row_position, START_COLUMN), _
            new_ws1.Cells(row_position + 1, START_COLUMN + 6) _
        ).Borders(xlInsideHorizontal).LineStyle = xlNone
    
        ' 曜日の下の枠線を薄い線に
        new_ws1.Range( _
            new_ws1.Cells(row_position + 1, START_COLUMN), _
            new_ws1.Cells(row_position + 2, START_COLUMN + 6) _
        ).Borders(xlInsideHorizontal).Weight = xlHairline
    
    Next row_position

    ' グリッド線を非表示にする
    Set new_window = Application.Windows(new_wb.Name)
    new_window.DisplayGridlines = False


End Sub