Excelについて

添付写真上のExcelシートのように時間と曜日ごとに担当者が振り分けられているシートがあります。
例えば、写真左側のようなシートを作成し、B3セルに日付を記入し、マクロを使用し曜日毎の担当者を抜粋した写真右のようなシートを1か月分（約30枚のシート）を毎月作成していきたいです。
（月1回この作業をするものとする）
マクロ初心者ですが、教えていただきたいです。よろしくお願いいたします。

No.1 ベストアンサー 回答者： 河内のおやじ 回答日時： 2023/03/06 10:39

Sub CreateSchedule()

Dim dt As Date
Dim lastRow As Long
Dim i As Long, j As Long
Dim days As Variant
Dim names As Variant
Dim schedule As Variant
Dim ws As Worksheet

Set ws = ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count))

' シートのタイトルを設定
ws.Name = "Schedule " & Format(Date, "yyyy-mm")
ws.Range("A1").Value = "Date"
ws.Range("B1").Value = "Day of Week"
ws.Range("C1").Value = "Name"

' 出力する日付範囲を取得
dt = Range("B3").Value
days = Array("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

' 日付範囲ごとに担当者を取得
For i = 1 To 30
ws.Cells(lastRow + i, "A").Value = dt
ws.Cells(lastRow + i, "B").Value = days(Weekday(dt, vbSunday) - 1)
names = WorksheetFunction.Transpose(Range("C5:C11"))
schedule = WorksheetFunction.Transpose(Range("D5:D11"))
For j = LBound(names) To UBound(names)
If InStr(schedule(j), days(Weekday(dt, vbSunday) - 1)) > 0 Then
ws.Cells(lastRow + i, "C").Value = names(j)
Exit For
End If
Next j
dt = dt + 1
Next i

MsgBox "Schedule created successfully."
End Sub