Sub CreateScheduleSheet()
Dim ws As Worksheet
Dim i As Integer, j As Integer
Dim startDate As Date
Dim endDate As Date
Dim numWeeks As Integer
Dim colorIndex As Long
' "Schedule"という名前のワークシートが存在する場合、それを削除
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Sheets("Schedule").Delete
Application.DisplayAlerts = True
On Error GoTo 0
' 新しいワークシートを作成
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "Schedule"
' 項目名と担当者の列を作成
ws.Cells(1, 1).Value = "項目名"
ws.Cells(1, 2).Value = "担当者"
' セルの幅を設定
ws.Columns(1).ColumnWidth = 10 * 2 ' 全角10文字分の幅
ws.Columns(2).ColumnWidth = 3 * 2 ' 全角3文字分の幅
' 今日の日付から最も近い月曜日の日付を取得
startDate = Date - Weekday(Date, vbMonday) + 1
' 今日の日付から6か月後までの日付を取得
endDate = DateAdd("m", 6, startDate)
' 週単位での期間を計算
numWeeks = DateDiff("ww", startDate, endDate)
' 色のインデックスを初期化（色は月ごとに変わる）
colorIndex = RGB(255, 255, 255) ' 初期値は白色
' 週単位の日付列を作成
j = 3
For i = 0 To numWeeks
ws.Cells(1, j).Value = DateAdd("ww", i, startDate)
ws.Cells(1, j).NumberFormat = "mm/dd" ' セルの書式を月/日に設定
' 色を設定（色は月ごとに変わる）
If Month(ws.Cells(1, j).Value) Mod 2 = 0 Then
colorIndex = RGB(255, 255, 0) ' 黄色（偶数月）
Else
colorIndex = RGB(173,216,230) ' ライトブルー（奇数月）
End If
ws.Cells(1, j).Interior.Color = colorIndex
ws.Columns(j).AutoFit ' セルの幅を内容に合わせて自動調整
j = j + 1
Next i
' 項目行の書式を設定
With ws.Range(ws.Cells(1, 1), ws.Cells(1, j - 1))
.HorizontalAlignment = xlCenter ' 文字を中央揃えに設定
.VerticalAlignment = xlCenter ' 文字を中央揃えに設定
.WrapText = True ' 文字列がセルに収まらない場合は折り返すように設定
.Font.Bold = True ' フォントを太字に設定
.Borders.LineStyle = xlContinuous ' 枠線を連続線に設定
.Borders.Weight = xlThin ' 枠線の太さを細く設定
.Borders.Color = RGB(0, 0, 0) ' 枠線の色を黒に設定
.RowHeight = 20 ' 行の高さを20ポイントに設定
.EntireRow.AutoFit ' 行の高さを内容に合わせて自動調整するように設定
End With
End Sub
