前にExcelでシフト自動作成マクロを作りました。現在のところこのブログで最も見られている記事で、相当シフト作成に苦労されているところが多いんだなと見受けます。
内容的にはあらかじめ予定をセットしておいてプログラムを走らせたら、ランダムで配置していくというもの。
複雑な勤務体系の場合はどうしても勤務や休みに偏りが出てしまうのですが、それを機械任せにすることで公平性をもたせるという目的です。
ただ、イマイチだったのがランダムゆえの偏りが発生してしまいがちなのが気になっていました。毎回抽選し直していたので、連続で同じ人が同じ配置についてしまうことがしばしば。
そこで、抽選する配列には行番号や列番号を入れておき、一巡してからシャッフルするという風に作り変えました。
※改良に改良を重ねた最新版は下のリンクからどうぞ。
プログラムの内容
こちらがサンプルのデータです。
フォーマット自体もかなり変えました。
前回は設定用のシートを別に設けていましたが、シフト表の右側にまとめました（以下、設定リストとよびます）。シートが別だと設定するのを忘れてしまいがちなので、この方がミスが少ないですよね。
設定リストの早出、遅出、夜勤が入っているセルの色をセットするようにしています。これでお好みの色にすることができます。また、その上の人数と書かれた行の数字の数だけ配置します。
実行ボタンを押した後です。割とバランスよく並んでいるかと思います。
要件としましては、今回は夜勤を１労働としてカウント、なるべく連続で入るようにして、その場合は２連休を配置するようにしました。
前回は労基的な意味で７連勤にならないようにしていましたが、今回は廃止しました。いろいろ方法を考えましたが、ループしてしまう可能性が少しでもあったので。バグをなくすことを最優先に考えました。
プログラミング
Module1 – シフト自動作成
Sub シフト自動作成()
Dim rowStart As Integer '開始行
Dim rowEnd As Integer '終了行
Dim colStart As Integer '開始列
Dim colEnd As Integer '最終列
Dim maxHol As Integer '公休日数
Dim colCfg As Integer '設定列
Dim holStr As String '「公休」文字列
'初期設定
rowStart = 6
colStart = 3
colCfg = 39
Cells(rowStart, 1).Select
rowEnd = Selection.End(xlDown).Row
Cells(rowStart - 3, colStart).Select
colEnd = Selection.End(xlToRight).Column
holStr = "公休"
'最終列から公休日数を決定
Select Case colEnd
Case 33
maxHol = 10
Case 30
maxHol = 8
Case Else
maxHol = 9
End Select
'行番号を配列に格納
ReDim rowArr(rowEnd - rowStart) As Variant
For i = 0 To rowEnd - rowStart
rowArr(i) = i + rowStart
Next
'列番号を配列に格納
ReDim colArr(colEnd - colStart) As Variant
For i = 0 To colEnd - colStart
colArr(i) = i + colStart
Next
'シートを複製
Dim thisSheetName As String '複製元のシート名
thisSheetName = ActiveSheet.Name
Worksheets(thisSheetName).Copy Before:=Worksheets(thisSheetName)
ActiveSheet.Name = thisSheetName & "作成済"
'夜勤配置
Dim setStr As String '配置名
Dim setClr As Variant 'セルの背景色
Dim setCnt As Integer '配置数を数えるカウンタ
Dim setCnt2 As Integer '翌日分の配置数を数えるカウンタ
Dim arrCnt As Integer '配列用のカウンタ
'初回のシャッフル
Call 抽選(rowArr())
arrCnt = 0
setStr = Cells(rowStart - 1, colCfg + 3).Value
setClr = Cells(rowStart - 1, colCfg + 3).Interior.Color
'列を走査し夜勤を配置
For i = colStart To colEnd
setCnt = Cells(rowStart - 2, colCfg + 3).Value
setCnt2 = setCnt
'行を走査し必要な夜勤配置数を計算
For j = rowStart To rowEnd
If Cells(j, i).Value = setStr Then
setCnt = setCnt - 1
If setCnt = 0 Then
Exit For
End If
End If
Next j
Do While setCnt > 0
'条件を満たせば配置
If Cells(rowArr(arrCnt), i).Value = "" _
And Cells(rowArr(arrCnt), i + 1).Value = "" _
And Cells(rowArr(arrCnt), colCfg).Value = 1 _
And Cells(rowArr(arrCnt), colCfg + 3).Value = 1 Then
Cells(rowArr(arrCnt), i).Value = setStr
Cells(rowArr(arrCnt), i).Interior.Color = setClr
setCnt = setCnt - 1
'連続夜勤処理
If i < colEnd Then
For j = rowStart To rowEnd
If Cells(j, i + 1).Value = setStr Then
setCnt2 = setCnt2 - 1
If setCnt2 = 0 Then
Exit For
End If
End If
Next j
'条件を満たせば連続夜勤、満たさなければ公休を配置
If setCnt2 > 0 And Cells(rowArr(arrCnt), i + 2).Value = "" Then
Cells(rowArr(arrCnt), i + 1).Value = setStr
Cells(rowArr(arrCnt), i + 1).Interior.Color = setClr
If i < colEnd - 1 Then
Cells(rowArr(arrCnt), i + 2).Value = holStr
If i < colEnd - 2 And Cells(rowArr(arrCnt), i + 3).Value = "" Then
Cells(rowArr(arrCnt), i + 3).Value = holStr
End If
End If
Else
Cells(rowArr(arrCnt), i + 1).Value = holStr
End If
End If
'連続夜勤処理ここまで
End If
'配列用カウンタ処理
If arrCnt = UBound(rowArr()) Then
Call 抽選(rowArr())
arrCnt = 0
'空欄チェック
Call 列走査(rowStart, rowEnd, i, setCnt, colCfg)
Else
arrCnt = arrCnt + 1
End If
Loop
Next i
'公休を配置
Dim holCnt As Integer
Call 抽選(colArr())
arrCnt = 0
'行を走査し公休を配置
For i = rowStart To rowEnd
If Cells(i, colCfg).Value = 1 Then
holCnt = maxHol
'公休の残り日数を計算
For j = colStart To colEnd
If Cells(i, j).Value = holStr Then
holCnt = holCnt - 1
If holCnt = 0 Then
Exit Sub
End If
End If
Next j
'公休を配置
Do While holCnt > 0
'空欄であれば公休配置
If Cells(i, colArr(arrCnt)).Value = "" Then
Cells(i, colArr(arrCnt)).Value = holStr
holCnt = holCnt - 1
End If
'配列用カウンタ処理
If arrCnt = UBound(colArr()) Then
Call 抽選(colArr())
arrCnt = 0
Else
arrCnt = arrCnt + 1
End If
'空欄チェック
Call 行走査(colStart, colEnd, i, holCnt, colCfg)
Loop
End If
Next i
'早出と遅出を配置
Dim hoColArr() As Variant
Dim hoStrArr() As Variant
Dim hoClrArr() As Variant
Dim hoCntArr() As Variant
hoColArr = Array(colCfg + 1, colCfg + 2)
hoStrArr = Array(Cells(rowStart - 1, hoColArr(0)).Value, Cells(rowStart - 1, hoColArr(1)).Value)
hoClrArr = Array(Cells(rowStart - 1, hoColArr(0)).Interior.Color, Cells(rowStart - 1, hoColArr(1)).Interior.Color)
hoCntArr = Array(Cells(rowStart - 2, hoColArr(0)).Value, Cells(rowStart - 2, hoColArr(1)).Value)
Call 抽選(rowArr())
arrCnt = 0
'列を走査し早出と遅出を配置
For i = colStart To colEnd
'早出は0、遅出は1
For j = 0 To 1
setCnt = hoCntArr(j)
'早出or遅出の必要な配置数を計算
For k = rowStart To rowEnd
If Cells(k, i).Value = hoStrArr(j) Then
setCnt = setCnt - 1
If setCnt = 0 Then
Exit For
End If
End If
Next k
Do While setCnt > 0
'条件を満たせば早出or遅出を配置
If Cells(rowArr(arrCnt), colCfg + 1 + j).Value = 1 And Cells(rowArr(arrCnt), i).Value = "" Then
Cells(rowArr(arrCnt), i).Value = hoStrArr(j)
Cells(rowArr(arrCnt), i).Interior.Color = hoClrArr(j)
setCnt = setCnt - 1
End If
'配列用カウンタ処理
If arrCnt = UBound(rowArr()) Then
Call 抽選(rowArr())
arrCnt = 0
Else
arrCnt = arrCnt + 1
End If
'空欄チェック
Call 列走査(rowStart, rowEnd, i, setCnt, colCfg)
Loop
Next j
Next i
End Sub
Sub 抽選(ByRef myArr() As Variant)
'配列の順番をシャッフルして返す
For i = 0 To UBound(myArr)
Randomize
rn = Int(UBound(myArr) * Rnd)
tmp = myArr(i)
myArr(i) = myArr(rn)
myArr(rn) = tmp
Next
End Sub
Sub 列走査(ByVal rowStart As Integer, ByVal rowEnd As Integer, ByVal chkCol As Variant, ByRef cnt As Integer, ByVal colCfg As Integer)
'列を走査して空欄が無ければ次の行へ進む
Dim nextFlg As Boolean
nextFlg = True
For i = rowStart To rowEnd
If Cells(i, chkCol).Value = "" And Cells(i, colCfg).Value = 1 Then
nextFlg = False
Exit For
End If
Next
If nextFlg = True Then
cnt = 0
End If
End Sub
Sub 行走査(ByVal colStart As Integer, ByVal colEnd As Integer, ByVal chkRow As Variant, ByRef cnt As Integer, ByVal colCfg As Integer)
'行を走査して空欄が無ければ次の列へ進む
Dim nextFlg As Boolean
nextFlg = True
For i = colStart To colEnd
If Cells(chkRow, i).Value = "" And Cells(chkRow, colCfg).Value = 1 Then
nextFlg = False
Exit For
End If
Next
If nextFlg = True Then
cnt = 0
End If
End Sub今回は公休を確実に取らせるために、夜勤→公休→日勤という順に配置していきます。夜勤が先に来ているのは公休との関連が強いからです。
大きく変えたのは配列の考え方。前回は設定シートから職員の情報を配列に入れて、日ごとに配列をシャッフルして取り出すということをしていました。これだとランダムとはいえ30日連続同じ配置ということもありえます。
配列のシャッフルはrandomPro()で行います。今回は夜勤と日勤を配置する時は行番号、公休を配置する時は列番号を配列にセットし、一度シャッフルした配列は最後のインデックスが取り出されてからシャッフルするという方式にしました。これでかなり分散させることができます。
配置できたらカウンタを減らして、0になったら次のフェーズへ移行するのですが、全部のセルが埋まっていてカウンタが0にならない事態を防ぐために、配列をシャッフルするタイミングで空白セルがあるかどうかをチェックするcolChkPro()とrowChkPro()を用意しました。
2021年3月21日追記
コメント欄でお知らせくださったのですが、設定リストの早出と遅出のON/OFFがうまく機能していませんでした。
「If Cells(rowArr(arrCnt), colCfg + 1 + j).Value = 1（以下略）」とすべきところを、「If Cells(rowArr(arrCnt), colCfg + 1).Value = 1（以下略）」としていたため、常勤列の1 or 0で判定するようになっていました。
ファイルを更新していますので差し替えていただくか、Module1をそのまま上記のコードで上書きしてください。
Module2 – 新規シート作成
Sub 新規()
Dim colStart As Integer '開始列
Dim colEnd As Integer '最終列
Dim rowStart As Integer '開始行
Dim rowEnd As Integer '最終行
Dim thisYear As Variant '年
Dim thisMonth As Variant '月
Dim thisSheetName As String 'シート名
Dim fstWeekday As Variant '1日の曜日
colStart = 3
colEnd = 33
rowStart = 6
Cells(rowStart, 1).Select
rowEnd = Selection.End(xlDown).Row
'年月入力
Dim thisYear As String
thisYear = Application.InputBox("西暦を半角4桁の数字で入力してください。")
If thisYear = False Then
Exit Sub
End If
If Len(thisYear) <> 4 Then
MsgBox ("西暦は4桁で入力してください。" _
& vbCrLf & "処理を中止します。")
Exit Sub
End If
thisMonth = Application.InputBox("月を半角で入力してください。（1～12）")
If thisMonth = False Then
Exit Sub
End If
If thisMonth < 1 Or thisMonth > 12 Then
MsgBox ("月は1～12で入力してください。" _
& vbCrLf & "処理を中止します。")
Exit Sub
End If
'シートを複製
thisSheetName = ActiveSheet.Name
Worksheets(thisSheetName).Copy Before:=Worksheets(thisSheetName)
ActiveSheet.Name = thisYear & "." & thisMonth
Cells(2, 17).Value = thisMonth & "月勤務表"
'内容をクリア
Range(Cells(rowStart - 3, colStart), Cells(rowEnd, colEnd)).ClearContents
Range(Cells(rowStart, colStart), Cells(rowEnd, colEnd)).Interior.ColorIndex = xlNone
Range(Cells(rowStart - 3, colStart - 2), Cells(rowEnd, colEnd)).Borders.LineStyle = xlLineStyleNone
'月から最終列を決定
Select Case thisMonth
Case 4, 6, 9, 11
colEnd = 32
Case 2
If Not thisYear Mod 400 = 0 Then
If thisYear Mod 100 = 0 Then
colEnd = 30
ElseIf thisYear Mod 4 = 0 Then
colEnd = 31
Else
colEnd = 30
End If
End If
Case Else
colEnd = 33
End Select
'1日の曜日を取得
fstWeekday = Weekday(thisYear & "/" & thisMonth & "/1")
Select Case fstWeekday
Case 1
fstWeekday = "日"
Case 2
fstWeekday = "月"
Case 3
fstWeekday = "火"
Case 4
fstWeekday = "水"
Case 5
fstWeekday = "木"
Case 6
fstWeekday = "金"
Case 7
fstWeekday = "土"
End Select
'入力しオートフィル
Cells(rowStart - 3, colStart).Value = "1"
Cells(rowStart - 3, colStart).AutoFill Destination:=Range(Cells(rowStart - 3, colStart), Cells(rowStart - 3, colEnd)), Type:=xlFillSeries
Cells(rowStart - 2, colStart).Value = fstWeekday
Cells(rowStart - 2, colStart).AutoFill Destination:=Range(Cells(rowStart - 2, colStart), Cells(rowStart - 2, colEnd)), Type:=xlFillDays
Range(Cells(rowStart - 3, colStart - 2), Cells(rowEnd, colEnd)).Borders.LineStyle = xlContinuous
End Subこの辺はほぼ同じです。
Module3 – 配置ボタン
Sub 早出()
If Selection.Row >= 6 And Selection.Column >= 3 And Selection.Column <= 33 Then
Selection.Value = "早出"
Selection.Interior.Color = Cells(5, 40).Interior.Color
End If
End Sub
Sub 遅出()
If Selection.Row >= 6 And Selection.Column >= 3 And Selection.Column <= 33 Then
Selection.Value = "遅出"
Selection.Interior.Color = Cells(5, 41).Interior.Color
End If
End Sub
Sub 夜勤()
If Selection.Row >= 6 And Selection.Column >= 3 And Selection.Column <= 33 Then
Selection.Value = "夜勤"
Selection.Interior.Color = Cells(5, 42).Interior.Color
End If
End Sub
Sub 公休()
If Selection.Row >= 6 And Selection.Column >= 3 And Selection.Column <= 33 Then
Selection.Value = "公休"
Selection.Interior.ColorIndex = 0
End If
End Sub
Sub 年休()
If Selection.Row >= 6 And Selection.Column >= 3 And Selection.Column <= 33 Then
Selection.Value = "年休"
Selection.Interior.ColorIndex = 0
End If
End Sub
Sub 消去()
If Selection.Row >= 6 And Selection.Column >= 3 And Selection.Column <= 33 Then
Selection.Value = ""
Selection.Interior.Color = 16777215
End If
End Sub色の情報を設定リストから取得するようにしています。
ThisWorkbook – ハイライト
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Application.ScreenUpdating = True
End Sub
'条件付き書式に
'=OR(CELL("ROW")=ROW(), CELL("COL")=COLUMN())
'の条件で背景色を設定
コメント
夜勤の人数の件ですが、たとえば、その日に夜勤入と夜勤明けがありますが、設定で夜勤を2にすると夜勤入が二人重なるため、夜勤明けと夜勤入りができません。
当日に夜勤明けと夜勤入りを分けることは可能ですか？
コメントありがとうございます。
すみません、夜勤明けと夜勤入りを分けるという意味があまりわかりません。
夜勤入りの翌日は夜勤明けにするということでしょうか。
それでしたら前バージョンでやっておりますので、そちらを参考にしてください。
https://www.iehohs.com/excel-auto-shift/
返答ありがとうございます。
説明が悪くてすみません、早出・遅出・夜勤の色付きのところの数字を夜勤を2にした場合に夜勤入りのスタッフが同日に夜勤入りが2人になり、次の日はその２人が夜勤明けになるため、夜勤入も含めた場合は、当日は夜勤入1、夜勤明1 で夜勤は数通りに2で合計されますが、夜勤明けが２人になって夜勤入りがない状態になりますので、どのようにしたらよいでしょうか？よろしくお願いいたします。
１２月 1日 ２日
夜勤入 夜勤明
夜勤入 夜勤明
早出 早出
早出1 早出1
夜勤2 夜勤2
↑設定どおり夜勤は2になりますが、夜勤入がないためその日に夜勤に入る人がいない。
既にアレンジして「夜勤入」と「夜勤明」がランダムで入るようにされているということですかね。
元のプログラムとしては設定リストのところでR4C42のセルが「夜勤」となっていれば、既に入っている人数の確認は「夜勤」の文字列が入っている時のみカウンタを減らすので「夜勤入」および「夜勤明」どちらの場合でもカウンタは減らないはずです。
単純に「夜勤入」を設定した人数分配置したいのであればR4C42のセルを「夜勤入」に変更し、「夜勤入」が配置された翌日は「夜勤明」を設定するようにコードを書き足せばOKかと思います。
ちなみに「夜勤入」の翌日が必ず「夜勤明」になるということは２労働制の夜勤でしょうか。
夜分遅くに何度も返答ありがとうございます。
そうです、２労働制の夜勤です。コードはどのように書き足せばよろしいですか？
「夜勤入」が入力されたらその次の列に「夜勤明」が入るようにコードを記述すればいいと思います。
具体的なコードについてはコメント欄でお伝えしないことにしているので、ご自身で頑張ってコーディングしてみてください。
どうしてもわからないのであれば、ランサーズあるいはクラウドワークスよりご依頼ください。
まさに私が欲しかった情報があって助かりました。
条件を一つ追加したい時などはどうやって記述すればいいでしょうか。
当直回数を本人の希望数にしたいと思っています。
Aさんが３回を希望してたら、元から配置した分+ランダム配置＝3
になった時点でBさんに以降するようにしたいと考えてます。
元から配置した分とランダムで配置された分があるので、わからなくなってしまいました。
コメントありがとうございます。
設定リストのところで希望回数を入力して運用することになると思うのですが、このサンプルのコードだと夜勤については１日ずつに設定していくので、それだと希望回数に満たない人も出てきてしまいます。上限回数として認識させることは可能ですが。
公休については１人ずつに決まった日数分ランダムで設定していくので、これを応用して夜勤を配置するのが良いかと思います。
仕組みは分かるのですが、コードが面倒になることが分かってるので、作り上げたことについて素晴らしいと思わせられました。これからも頑張ってくださいー！！
質問なのですが今回も配置可能を１、不可能を0として扱っているのでしょうか？サンプル画像を拝見したところ早出が0になっている方も早出が入っているのでそういう仕様はないコードになっているのでしょうか？
こんにちは。質問してもよろしいでしょうか？
作り直した方のコードだと1と0で配置の可不可を判定していないのでしょうか？初歩的な事ですいません。
すいません。消えたと勘違いして同じようなコメントをしてしまっています。
コメントありがとうございました。
初回のコメント投稿は承認するまで一旦止まる仕様になっているので、勘違いされるのも無理ないです。気にしないでください。
ご指摘いただいた点ですが、結論から申し上げると私の記述ミスでした。失礼いたしました。
ファイルおよびこの記事のコードを修正し、掲載さいているキャプチャも差し替えしました。
早出および遅出を自動入力するかは設定リストの0 or 1で切り替えていましたが、修正前のコードでは常勤列で判定していたため早出列が0だったとしても常勤列が1であれば早出も自動入力するという状態でした。
コメントしていただいて大変助かりました。ありがとうございました。
今後もお気付きの点がございましたらコメントを頂けますと幸いです。
対応ありがとうございます！