『当番表のご相談』（asd）
月の当番表を作成するにあたりご相談です。
職員数：５人
１日あたりの担当者数：２人
担当日：土日祝を除く平日（個人休暇等は無視してOK）
条件：連続して３日間の担当にならないようにする
月の中で担当する日数はできるだけ均等にする
できるだけ同じ組み合わせにならないようにする
以上の条件を満たすカレンダーを作りたいのです。
現在自動で日付、祝日が反映される万年カレンダーは作成しておりますが、担当割をどうすればいいかわからず困っております。
日付の下にそれぞれ名前が入るような形にできればありがたいです。以下がイメージです。
2025年4月
月 火 水 木 金 土 日
1 2 3 4 5 6
A C E B D A 7 8 9 10 11 12 13
14 15 16 17 18 19 20
21 22 23 24 25 26 27
28 29 30
以上よろしくお願いいたします。
＜ 使用 Excel：Excel2016、使用 OS：unknown ＞
コメントが無いようなので、たたき台を提示します。 いくつかのステップに分けて、手作業とマクロを組み合わせるローテクです。
(1)5人から2人を選択する方法は10とおりです。
1 A B
2 A C
3 A D
4 A E
5 B C
6 B D
7 B E
8 C D
9 C E
10 D E
(2)
この表のD列に乱数を書き入れ、その乱数でソートして、順序をランダム化します。
このなかで３連続担当がないものを合格とすれば、
3条件を満たす10日間の担当表はできます。
(3)
この10日間表を、いくつかつなぎ合わせて、より長いものを作ります。
注意点は、つなぎ目で3連続担当とならないようにすることです。
3連続となったら、10日間表の順序を適宜入れ替えるとよいでしょう。
(4)
こうして３か月くらいの担当表を作ります。
(5)
あとは、
日付 担当1 担当2
2025/4/1 A B
2025/4/2 C D
・・・・ ・・ ・・
のような日付と担当表を表にしたものとし、
カレンダーからは、VLOOKUPか何かで表引きすればよいでしょう。
(2)のところは、簡単なマクロを組めばできると思います。トライされたらいかがでしょう。
念のための確認ですが、上記は5人の職員で、担当数は2という前提の話です。 「いやあそれは例えばの話であって、実際はもっと数は多いです。」 などと言う後出しが無いことが前提です。
（xyz） 2025/03/14(金) 08:50:17
同じく「たたき台」を提示。
イメージがさっぱりわからないので
指定年月から希望にそう当番（2名）を割り当てるコードです。
Option Explicit
Sub 当番表作成()
Dim 職員数 As Integer, 担当者数 As Integer
Dim 年 As Integer, 月 As Integer
Dim i As Integer, j As Integer, 日 As Integer
Dim 候補者() As Integer, 当番() As Integer
Dim 最終行 As Integer, 連続日数() As Integer
' 設定
職員数 = 5
担当者数 = 2
' 年月の入力
Do
年 = CInt(Application.InputBox("年を入力してください (例: 2025)", Type:=1))
If 年 = 0 Then Exit Sub ' キャンセルされた場合
Loop Until 年 >= 1900 And 年 <= 9999
Do
月 = CInt(Application.InputBox("月を入力してください (1-12)", Type:=1))
If 月 = 0 Then Exit Sub ' キャンセルされた場合
Loop Until 月 >= 1 And 月 <= 12
' 配列の初期化
ReDim 連続日数(1 To 職員数)
ReDim 候補者(1 To 職員数)
For i = 1 To 職員数
候補者(i) = i
Next i
' シートのクリア
Cells.Clear
' ヘッダーの設定
Cells(1, 1) = "日付"
Cells(1, 2) = "曜日"
Cells(1, 3) = "当番1"
Cells(1, 4) = "当番2"
' 当番表の作成
最終行 = 1
For 日 = 1 To Day(DateSerial(年, 月 + 1, 0))
If Weekday(DateSerial(年, 月, 日), vbMonday) <= 5 Then ' 平日のみ
最終行 = 最終行 + 1
Cells(最終行, 1) = DateSerial(年, 月, 日)
Cells(最終行, 2) = Format(DateSerial(年, 月, 日), "aaa")
' 当番の選択
ReDim 当番(1 To 担当者数)
For i = 1 To 担当者数
Do
j = Int((職員数 * Rnd) + 1)
Loop Until 連続日数(j) < 3 And Not IsInArray(j, 当番)
当番(i) = j
連続日数(j) = 連続日数(j) + 1
Cells(最終行, i + 2) = "職員" & j
Next i
' 連続日数のリセット
For i = 1 To 職員数
If Not IsInArray(i, 当番) Then
連続日数(i) = 0
End If
Next i
End If
Next 日
' 罫線の設定
Range(Cells(1, 1), Cells(最終行, 4)).Borders.LineStyle = xlContinuous
' 列幅の調整
Columns("A:D").AutoFit
End Sub
Function IsInArray(val As Variant, arr As Variant) As Boolean
Dim element As Variant
For Each element In arr
If element = val Then
IsInArray = True
Exit Function
End If
Next element
IsInArray = False
End Function
（暇な人） 2025/03/14(金) 09:04:53
ただ、いただいたコードを実行すると、均等にならず、何度か試しましたが、一番多い人と、少ない人で最大５回ほど担当回数に差が開く結果となってしまいます。これは極力均等に割り振ることはできるのでしょうか。
（aser） 2025/03/14(金) 10:28:22
ただし、完全に均等にはならない場合もあります。
追加で月末での各職員の担当回数を表示するようにしました。
Option Explicit
Sub 当番表作成v2()
Dim 職員数 As Integer, 担当者数 As Integer
Dim 年 As Integer, 月 As Integer
Dim i As Integer, j As Integer, 日 As Integer
Dim 候補者() As Integer, 当番() As Integer
Dim 最終行 As Integer, 連続日数() As Integer
Dim 担当回数() As Integer
Dim 最小回数 As Integer, 最大回数 As Integer
' 設定
職員数 = 5
担当者数 = 2
' 年月の入力
Do
年 = CInt(Application.InputBox("年を入力してください (例: 2025)", Type:=1))
If 年 = 0 Then Exit Sub ' キャンセルされた場合
Loop Until 年 >= 1900 And 年 <= 9999
Do
月 = CInt(Application.InputBox("月を入力してください (1-12)", Type:=1))
If 月 = 0 Then Exit Sub ' キャンセルされた場合
Loop Until 月 >= 1 And 月 <= 12
' 配列の初期化
ReDim 連続日数(1 To 職員数)
ReDim 担当回数(1 To 職員数)
ReDim 候補者(1 To 職員数)
For i = 1 To 職員数
候補者(i) = i
担当回数(i) = 0
Next i
' シートのクリア
Cells.Clear
' ヘッダーの設定
Cells(1, 1) = "日付"
Cells(1, 2) = "曜日"
Cells(1, 3) = "当番1"
Cells(1, 4) = "当番2"
' 当番表の作成
最終行 = 1
For 日 = 1 To Day(DateSerial(年, 月 + 1, 0))
If Weekday(DateSerial(年, 月, 日), vbMonday) <= 5 Then ' 平日のみ
最終行 = 最終行 + 1
Cells(最終行, 1) = DateSerial(年, 月, 日)
Cells(最終行, 2) = Format(DateSerial(年, 月, 日), "aaa")
' 当番の選択
ReDim 当番(1 To 担当者数)
For i = 1 To 担当者数
' 最小回数と最大回数を計算
最小回数 = Application.Min(担当回数)
最大回数 = Application.Max(担当回数)
Do
j = Int((職員数 * Rnd) + 1)
Loop Until 連続日数(j) < 3 And Not IsInArray(j, 当番) And _
(担当回数(j) = 最小回数 Or 最大回数 - 担当回数(j) > 1)
当番(i) = j
連続日数(j) = 連続日数(j) + 1
担当回数(j) = 担当回数(j) + 1
Cells(最終行, i + 2) = "職員" & j
Next i
' 連続日数のリセット
For i = 1 To 職員数
If Not IsInArray(i, 当番) Then
連続日数(i) = 0
End If
Next i
End If
Next 日
' 罫線の設定
Range(Cells(1, 1), Cells(最終行, 4)).Borders.LineStyle = xlContinuous
' 列幅の調整
Columns("A:D").AutoFit
' 担当回数の表示
Cells(最終行 + 2, 1) = "担当回数"
For i = 1 To 職員数
Cells(最終行 + 2 + i, 1) = "職員" & i
Cells(最終行 + 2 + i, 2) = 担当回数(i)
Next i
End Sub
Function IsInArray(val As Variant, arr As Variant) As Boolean
Dim element As Variant
For Each element In arr
If element = val Then
IsInArray = True
Exit Function
End If
Next element
IsInArray = False
End Function
（暇な人） 2025/03/14(金) 15:17:31
ちなみに土日は担当割り振りなされないようになっていのですが、祝日についても同様に割り振りから除外できるのでしょうか。
そこだけ何とかなればもうあとは完璧なのですが。
（aser） 2025/03/14(金) 15:51:40
祝日を考慮するのを忘れていたので祝日データを追加してみました。
（適当なので間違っている可能性が有ります。）
もっとスマートな方法があると思いますのが祝日を決め打ちで入力しています。
後は、祝日を表から取り出すとか、お好きに変更してください。
Option Explicit
Sub 当番表作成v3()
Dim 職員数 As Integer, 担当者数 As Integer
Dim 年 As Integer, 月 As Integer
Dim i As Integer, j As Integer, 日 As Integer
Dim 候補者() As Integer, 当番() As Integer
Dim 最終行 As Integer, 連続日数() As Integer
Dim 担当回数() As Integer
Dim 最小回数 As Integer, 最大回数 As Integer
' 設定
職員数 = 5
担当者数 = 2
' 年月の入力
Do
年 = CInt(Application.InputBox("年を入力してください (例: 2025)", Type:=1))
If 年 = 0 Then Exit Sub ' キャンセルされた場合
Loop Until 年 >= 1900 And 年 <= 9999
Do
月 = CInt(Application.InputBox("月を入力してください (1-12)", Type:=1))
If 月 = 0 Then Exit Sub ' キャンセルされた場合
Loop Until 月 >= 1 And 月 <= 12
' 配列の初期化
ReDim 連続日数(1 To 職員数)
ReDim 担当回数(1 To 職員数)
ReDim 候補者(1 To 職員数)
For i = 1 To 職員数
候補者(i) = i
担当回数(i) = 0
Next i
' シートのクリア
Cells.Clear
' ヘッダーの設定
Cells(1, 1) = "日付"
Cells(1, 2) = "曜日"
Cells(1, 3) = "当番1"
Cells(1, 4) = "当番2"
' 当番表の作成
最終行 = 1
For 日 = 1 To Day(DateSerial(年, 月 + 1, 0))
If Weekday(DateSerial(年, 月, 日), vbMonday) <= 5 And Not IsHoliday(DateSerial(年, 月, 日)) Then ' 平日かつ祝日でない場合
最終行 = 最終行 + 1
Cells(最終行, 1) = DateSerial(年, 月, 日)
Cells(最終行, 2) = Format(DateSerial(年, 月, 日), "aaa")
' 当番の選択
ReDim 当番(1 To 担当者数)
For i = 1 To 担当者数
' 最小回数と最大回数を計算
最小回数 = Application.Min(担当回数)
最大回数 = Application.Max(担当回数)
Do
j = Int((職員数 * Rnd) + 1)
Loop Until 連続日数(j) < 3 And Not IsInArray(j, 当番) And _
(担当回数(j) = 最小回数 Or 最大回数 - 担当回数(j) > 1)
当番(i) = j
連続日数(j) = 連続日数(j) + 1
担当回数(j) = 担当回数(j) + 1
Cells(最終行, i + 2) = "職員" & j
Next i
' 連続日数のリセット
For i = 1 To 職員数
If Not IsInArray(i, 当番) Then
連続日数(i) = 0
End If
Next i
End If
Next 日
' 罫線の設定
Range(Cells(1, 1), Cells(最終行, 4)).Borders.LineStyle = xlContinuous
' 列幅の調整
Columns("A:D").AutoFit
' 担当回数の表示
Cells(最終行 + 2, 1) = "担当回数"
For i = 1 To 職員数
Cells(最終行 + 2 + i, 1) = "職員" & i
Cells(最終行 + 2 + i, 2) = 担当回数(i)
Next i
End Sub
Function IsInArray(val As Variant, arr As Variant) As Boolean
Dim element As Variant
For Each element In arr
If element = val Then
IsInArray = True
Exit Function
End If
Next element
IsInArray = False
End Function
Function IsHoliday(targetDate As Date) As Boolean
Dim holidays() As Variant
' 2025年の祝日データ
holidays = Array(#1/1/2025#, #1/13/2025#, #2/11/2025#, #2/24/2025#, #3/14/2025#, #3/20/2025#, # _
4/29/2025#, #5/5/2025#, #5/6/2025#, #7/21/2025#, # _
8/11/2025#, #9/15/2025#, #9/23/2025#, #10/13/2025#, #11/3/2025#, # _
11/24/2025#)
Dim holiday As Variant
IsHoliday = False
For Each holiday In holidays
If targetDate = holiday Then
IsHoliday = True
Exit Function
End If
Next holiday
End Function
（暇な人） 2025/03/14(金) 16:29:49
ありがとうございます。
ちなみに祝日データは、祝日リストというシートを作成し、そこで祝日リストというリストを名前ボックスで管理しているのですが、そちらを引用するにはどうすればいいでしょうか。
何度もすみませんがお願いいたします。
（aser） 2025/03/17(月) 13:51:42
'祝日データ(年度別の祝日など）について
新しいシートを作成、名前を「祝日リスト」
A列に祝日データを日付形式で入力（yyyyy/mm/dd）後
祝日データの範囲を選択し、名前ボックスに「祝日一覧」と入力して名前定義。
名前定義された範囲は自動拡張されないため、
新しい祝日を追加した際は範囲の再定義の事。
Sub 当番表作成v4()
'...（中身は変更なし）...
End Sub
Function IsInArray(val As Variant, arr As Variant) As Boolean
'...（中身は変更なし）...
End Function
Function IsHoliday(targetDate As Date) As Boolean
Dim ws As Worksheet
Dim holidayRange As Range
Dim cell As Range
On Error Resume Next
Set ws = ThisWorkbook.Sheets("祝日リスト")
Set holidayRange = ws.Range("祝日一覧")
On Error GoTo 0
If holidayRange Is Nothing Then
IsHoliday = False
Exit Function
End If
For Each cell In holidayRange
If IsDate(cell.Value) Then
If DateValue(cell.Value) = targetDate Then
IsHoliday = True
Exit Function
End If
End If
Next cell
IsHoliday = False
End Function
（暇な人） 2025/03/18(火) 06:29:45
(中身は変化なし)と記載しましたが
修正前の「' 2025年の祝日データ」を削除して
代わりに「祝日リスト」シートの「祝日一覧」として参照するように変更する事を忘却していました。
Option Explicit
Sub 当番表作成v5()
Dim 職員数 As Integer, 担当者数 As Integer
Dim 年 As Integer, 月 As Integer
Dim i As Integer, j As Integer, 日 As Integer
Dim 候補者() As Integer, 当番() As Integer
Dim 最終行 As Integer, 連続日数() As Integer
Dim 担当回数() As Integer
Dim 最小回数 As Integer, 最大回数 As Integer
' 設定
職員数 = 5
担当者数 = 2
' 年月の入力
Do
年 = CInt(Application.InputBox("年を入力してください (例: 2025)", Type:=1))
If 年 = 0 Then Exit Sub ' キャンセルされた場合
Loop Until 年 >= 1900 And 年 <= 9999
Do
月 = CInt(Application.InputBox("月を入力してください (1-12)", Type:=1))
If 月 = 0 Then Exit Sub ' キャンセルされた場合
Loop Until 月 >= 1 And 月 <= 12
' 配列の初期化
ReDim 連続日数(1 To 職員数)
ReDim 担当回数(1 To 職員数)
ReDim 候補者(1 To 職員数)
For i = 1 To 職員数
候補者(i) = i
担当回数(i) = 0
Next i
' シートのクリア
Cells.Clear
' ヘッダーの設定
Cells(1, 1) = "日付"
Cells(1, 2) = "曜日"
Cells(1, 3) = "当番1"
Cells(1, 4) = "当番2"
' 当番表の作成
最終行 = 1
For 日 = 1 To Day(DateSerial(年, 月 + 1, 0))
If Weekday(DateSerial(年, 月, 日), vbMonday) <= 5 And Not IsHoliday(DateSerial(年, 月, 日)) Then ' 平日かつ祝日でない場合
最終行 = 最終行 + 1
Cells(最終行, 1) = DateSerial(年, 月, 日)
Cells(最終行, 2) = Format(DateSerial(年, 月, 日), "aaa")
' 当番の選択
ReDim 当番(1 To 担当者数)
For i = 1 To 担当者数
' 最小回数と最大回数を計算
最小回数 = Application.Min(担当回数)
最大回数 = Application.Max(担当回数)
Do
j = Int((職員数 * Rnd) + 1)
Loop Until 連続日数(j) < 3 And Not IsInArray(j, 当番) And _
(担当回数(j) = 最小回数 Or 最大回数 - 担当回数(j) > 1)
当番(i) = j
連続日数(j) = 連続日数(j) + 1
担当回数(j) = 担当回数(j) + 1
Cells(最終行, i + 2) = "職員" & j
Next i
' 連続日数のリセット
For i = 1 To 職員数
If Not IsInArray(i, 当番) Then
連続日数(i) = 0
End If
Next i
End If
Next 日
' 罫線の設定
Range(Cells(1, 1), Cells(最終行, 4)).Borders.LineStyle = xlContinuous
' 列幅の調整
Columns("A:D").AutoFit
' 担当回数の表示
Cells(最終行 + 2, 1) = "担当回数"
For i = 1 To 職員数
Cells(最終行 + 2 + i, 1) = "職員" & i
Cells(最終行 + 2 + i, 2) = 担当回数(i)
Next i
End Sub
Function IsInArray(val As Variant, arr As Variant) As Boolean
Dim element As Variant
For Each element In arr
If element = val Then
IsInArray = True
Exit Function
End If
Next element
IsInArray = False
End Function
Function IsHoliday(targetDate As Date) As Boolean
Dim ws As Worksheet
Dim holidayRange As Range
Dim cell As Range
On Error Resume Next
Set ws = ThisWorkbook.Sheets("祝日リスト")
Set holidayRange = ws.Range("祝日一覧")
On Error GoTo 0
If holidayRange Is Nothing Then
IsHoliday = False
Exit Function
End If
For Each cell In holidayRange
If IsDate(cell.Value) Then
If DateValue(cell.Value) = targetDate Then
IsHoliday = True
Exit Function
End If
End If
Next cell
IsHoliday = False
End Function
（暇な人） 2025/03/18(火) 06:43:03
|[A]|[B]|[C] |[D] |[E]
[1] | | | 2025| 8|
[2] |日 |曜 |行事予定|氏名１|氏名２
[3] | 1|金 | |山田 |撫佐
[4] | 2|土 | | |
[5] | 3|日 | | |
[6] | 4|月 | |水野 |高橋
[7] | 5|火 | |伊東 |山田
[8] | 6|水 | |撫佐 |水野
[9] | 7|木 | |高橋 |伊東
[10]| 8|金 | |山田 |撫佐
[11]| 9|土 | | |
[12]| 10|日 | | |
[13]| 11|月 |山の日 | |
[14]| 12|火 | |水野 |高橋
[15]| 13|水 | |伊東 |山田
[16]| 14|木 | |撫佐 |水野
[17]| 15|金 | |高橋 |伊東
[18]| 16|土 | | |
[19]| 17|日 | | |
[20]| 18|月 | |山田 |撫佐
[21]| 19|火 | |水野 |高橋
[22]| 20|水 | |伊東 |山田
[23]| 21|木 | |撫佐 |水野
[24]| 22|金 | |高橋 |伊東
[25]| 23|土 | | |
[26]| 24|日 | | |
[27]| 25|月 | |山田 |撫佐
[28]| 26|火 | |水野 |高橋
[29]| 27|水 | |伊東 |山田
[30]| 28|木 | |撫佐 |水野
[31]| 29|金 | |高橋 |伊東
[32]| 30|土 | | |
[33]| 31|日 | |山田 |撫佐
|[A] |[B] |[C] |[D] |[E] |[F] |[G]
[1] | |2025| 8| | | |
[2] |日 |月 |火 |水 |木 |金 |土
[3] | 27| 28| 29| 30| 31| 1| 2
[4] | | | | | |山田|
[5] | | | | | |撫佐|
[6] | 3| 4| 5| 6| 7| 8| 9
[7] | |水野|伊東|撫佐|高橋|山田|
[8] | |高橋|山田|水野|伊東|撫佐|
[9] | 10| 11| 12| 13| 14| 15| 16
[10]| | |水野|伊東|撫佐|高橋|
[11]| | |高橋|山田|水野|伊東|
[12]| 17| 18| 19| 20| 21| 22| 23
[13]| |山田|水野|伊東|撫佐|高橋|
[14]| |撫佐|高橋|山田|水野|伊東|
[15]| 24| 25| 26| 27| 28| 29| 30
[16]| |山田|水野|伊東|撫佐|高橋|
[17]| |撫佐|高橋|山田|水野|伊東|
[18]| 31| 1| 2| 3| 4| 5| 6
[19]|山田| | | | | |
[20]|撫佐| | | | | |
A4=IFERROR(VLOOKUP(A$3,LIST,4,0),"") A5=IFERROR(VLOOKUP(A$3,LIST,5,0),"") 〜 A19=IFERROR(VLOOKUP(A$18,LIST,4,0),"") A19=IFERROR(VLOOKUP(A$18,LIST,5,0),"") → へコピー 上の表全体を「LIST」と名前を付けています
（ひま） 2025/03/24(月) 16:43:53
(ひま)さんのコメントが、もし縦並びの表から、カレンダーへの転記法に絞ったものということであれば、 以下のコメントは的外れですのでスルーして下さい。
5日間の組み合わせを使いまわす方法だと、一人の人は、4人の相手のうち特定の2人に限定されるので、 >できるだけ同じ組み合わせにならないようにする の条件を満たしているのか疑念が生じます。
私の案は、10日間をワンセットで考える方式でした。 これは他の４人と必ず1回ずつ組むことになりますので、その要件は満たします。 あとは、3連続にならないように順序に気をつけることです。
このような（ひま）さんや私の方式のメリットは、各人の担当回数が公平になることです。 乱数方式で、月毎に決めていくと、長期間では担当回数が均されるのでしょうが、数か月単位でみると どうしても回数に差がでるとは思います。（もちろん、（暇な人）さんは百も承知かと思いますが） 手動での微修正で修正可能かとは思います。
（xyz） 2025/03/25(火) 09:42:00
A,B,C,D,Eの5人を以下の繰り返しで担当してもらえばよい。10日間セットです。
A B C D E
1 A B 1 1
2 C D 1 1
3 D E 1 1
4 A C 1 1
5 B C 1 1
6 A E 1 1
7 B D 1 1
8 B E 1 1
9 A D 1 1
10 C E 1 1
（xyz） 2025/03/25(火) 14:16:35
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.