24時間体制の部署ともなると勤務を組むのも一苦労で、１日仕事では済まないこともあるそうな。
そこでExcel VBAを使って条件通りにシフト表を自動作成するマクロを作成しました。
※改良に改良を重ねた最新版は下のリンクからどうぞ。
プログラムの内容
404 NOT FOUND | iEhohs.com
情シスの覚え書きブログです。
www.iehohs.com
サンプルのデータはこちらです。
シフト表を作成する上での要件をまとめます。
- 早出、日勤、遅出、夜勤の４種類の配置がある
- １日あたり夜勤は２人、それ以外は１人ずつを最低限配置する
- 夜勤は1.5労働とし、基本的に２日連続で入り翌日は「明け」、その翌日は公休とする
- 夜勤を連続で入れない場合は翌日を年次有給休暇（年休）を半日使用する「半年」、その翌日を公休とする
- ６日連続で勤務となった場合、公休を２日続けて取得する
- 役職や個人の都合により特定の配置にしかつけない場合、「職員リスト」シートで「0」を入力する
- 「職員リスト」では、１ヶ月あたりの夜勤の上限回数を指定する
操作について
上部に各種ボタンを配置しています。クリックするとマクロが動きます。
まず「新規」のボタンをクリックするとアクティブのシートを複製し、シフトをまっさらな状態にします。その際、年月を入力し、日数と曜日を取得します。
配置の書かれたボタンは、選択したセルにそれぞれの配置を入力することができます。希望休など予定が決まってるのでればあらかじめ入力しておきます。
実行ボタンを押すと、空いているセルに次々と配置を入れていきます。職員はランダムに選出され、既に予定が入っているところは避けます。また、既に定員分の入力がされている配置についてはスキップします。
これで決まっている予定を守りつつ最低限の配置がされます。あとは公休の日数を調整しながら、手動で配置をしていく感じです。
シフト作成作業の６割程度が自動化されるイメージです。公休の日数調整までやろうとすればできるのですが、勤務のバランスをとるのが難しいので、仕上げは人がやると割り切った方が効率的だという判断です。
プログラミング
Module1 – シフト表自動作成メイン処理
まずは最も中心となるマクロから。これは実行ボタンを押すと行われます。
Sub シフト表自動作成()
Dim thisSheetName As String '当月シフトのシート（マクロの実行シート）
Dim memSheetName As String '常勤リストのシート
Dim colStart As Integer '選択セルの列番号（この列からマクロ実行）
Dim colEnd As Integer '最終日数の列番号
Dim memberRow As Integer 'シフトの氏名
Dim memLengeth As Variant '職員数（常勤）
Dim allRow As Integer '専任も含めた職員名の最終行
Dim nLimit As Integer '夜勤の上限回数
Dim renLimit As Integer '連勤の上限回数
colStart = 3
startRow = 9
Cells(startRow - 6, colStart).Select
colEnd = Selection.End(xlToRight).Column
Cells(startRow, 1).Select
thisSheetName = ActiveSheet.Name
Worksheets(thisSheetName).Copy Before:=Worksheets(thisSheetName)
ActiveSheet.Name = thisSheetName & "作成済"
thisSheetName = ActiveSheet.Name
memSheetName = "職員リスト"
Worksheets(memSheetName).Activate
nLimit = Cells(7, 2).Value
Cells(startRow, 1).Select
memberRow = Selection.End(xlDown).Row
memLength = memberRow - 8
'職員名格納用配列
Dim member() As String
ReDim member(memLength) As String
'職員名を格納
For i = 0 To memberRow - 8
For j = 2 To 6
member(i) = member(i) & Cells(i + 9, j).Value
Next
Next
Worksheets(thisSheetName).Activate
Dim haichiArr() As Variant '配置名用配列
Dim codeArr() As Variant '各配置のコード用配列
Dim clrArr() As Variant '各配置の背景色用配列
Dim cntArr() As Variant '各配置のカウント用配列
haichiArr = Array("夜勤", "早出", "遅出", "日勤")
codeArr = Array("1*", "?1*", "??1*", "???1*")
clrArr = Array(65280, 16776960, 52479, 15773696)
'各列を走査して各配置の残りを計算
For i = colStart To colEnd
cntArr = Array(2, 1, 1, 1)
'各行を走査
For j = startRow To memberRow
If Cells(j, i).Value <> "" Then
Select Case Cells(j, i).Value
Case haichiArr(0)
cntArr(0) = cntArr(0) - 1
Case haichiArr(1)
cntArr(1) = cntArr(1) - 1
Case haichiArr(2)
cntArr(2) = cntArr(2) - 1
Case haichiArr(3)
cntArr(3) = cntArr(3) - 1
End Select
End If
Next j
'配置プロシージャ
Call 配置(member, memLength, memberRow, memSheetName, haichiArr, codeArr, clrArr, cntArr, startRow, colStart, i, colEnd, nLimit)
Next i
End Sub
Sub 配置(ByRef member() As String, _
ByVal memLength As Variant, _
ByVal memberRow As Integer, _
ByVal memSheetName As String, _
ByRef haichiArr() As Variant, _
ByRef codeArr() As Variant, _
ByRef clrArr() As Variant, _
ByRef cntArr() As Variant, _
ByVal startRow As Integer, _
ByVal colStart As Integer, _
ByVal setCol As Integer, _
ByVal colEnd As Integer, _
ByVal nLimit As Integer)
Dim setRow As Integer '配置行
Dim renyaCnt As Integer '連続夜勤カウント
Dim renYakin() As String '連続夜勤候補の配列
ReDim renYakin(1) As String
Dim setFlg As Boolean '配置フラグ
Dim ren6Cnt As Integer '６連勤カウント
Dim tmpCol As Integer '連勤チェック用の列番号
renyaCnt = -1
For i = 0 To 3
Do While cntArr(i) > 0
Call 抽選(member)
For j = 0 To memLength
If member(j) Like codeArr(i) Then
setRow = Right(member(j), 2)
If Cells(setRow, setCol).Value = "" Then
setFlg = True
'6連勤なら2連休
ren6Cnt = 0
tmpCol = setCol - 1
Do While Cells(setRow, tmpCol).Value = haichiArr(0) Or _
Cells(setRow, tmpCol).Value = haichiArr(1) Or _
Cells(setRow, tmpCol).Value = haichiArr(2) Or _
Cells(setRow, tmpCol).Value = haichiArr(3)
If tmpCol > 2 Then
ren6Cnt = ren6Cnt + 1
tmpCol = tmpCol - 1
If ren6Cnt >= 6 Then
Cells(setRow, setCol).Value = "公休"
For k = setCol + 1 To colEnd
If Cells(setRow, k).Value = "" Then
Cells(setRow, k).Value = "公休"
Exit For
End If
Next k
setFlg = False
Exit Do
End If
Else
Exit Do
End If
Loop
'夜勤の場合
If i = 0 And setFlg = True Then
'夜勤上限回数
If Cells(setRow, 37).Value >= nLimit Then
setFlg = False
End If
'翌日・翌々日に予定入りの場合は夜勤を設定しない
If Cells(setRow, setCol + 1).Value <> "" Or Cells(setRow, setCol + 2).Value <> "" Then
setFlg = False
End If
'セット可能なら連続夜勤の候補に入れる
If setCol <> colEnd And setFlg = True Then
renyaCnt = renyaCnt + 1
renYakin(renyaCnt) = member(j)
End If
End If
'条件を満たしていれば配置
If setFlg = True Then
Cells(setRow, setCol).Value = haichiArr(i)
Cells(setRow, setCol).Interior.Color = clrArr(i)
Exit For
End If
End If
End If
Next
cntArr(i) = cntArr(i) - 1
Loop
Next
'連続夜勤処理
If renyaCnt >= 0 And setCol <> colEnd Then
cntArr(0) = 2
For i = 9 To allRow
If Cells(i, setCol + 1).Value = haichiArr(0) Then
cntArr(0) = cntArr(0) - 1
End If
Next
For i = 0 To 2
Do While cntArr(i) > 0
Call 抽選(renYakin)
For j = 0 To renyaCnt
If renYakin(j) Like codeArr(i) Then
setRow = Right(renYakin(j), 2)
If Cells(setRow, setCol + 3).Value = "" Then
setFlg = True
If setFlg = True Then
Cells(setRow, setCol + 1).Value = haichiArr(i)
Cells(setRow, setCol + 1).Interior.Color = clrArr(i)
If setCol < colEnd - 1 Then
Cells(setRow, setCol + 2).Value = "明け"
End If
If setCol < colEnd - 2 Then
Cells(setRow, setCol + 3).Value = "公休"
End If
Exit For
End If
End If
End If
Next
cntArr(i) = cntArr(i) - 1
Loop
Next
'連続でない場合の夜勤後の処理
For i = 0 To 1
If renYakin(i) <> "" Then
setRow = Right(renYakin(i), 2)
If Cells(setRow, setCol + 1).Value = "" Then
Cells(setRow, setCol + 1).Value = "半年"
If setCol < colEnd - 1 Then
Cells(setRow, setCol + 2).Value = "公休"
End If
End If
End If
Next
End If
End Sub
Sub 抽選(ByRef member() As String)
For i = 0 To UBound(member)
Randomize
rn = Int(UBound(member) * Rnd)
tmp = member(i)
member(i) = member(rn)
member(rn) = tmp
Next
End Sub主にやっていることは、日数と人数を調べた上でひたすらループさせて、条件に合っていればシフトを配置するというのを繰り返しているだけです。
このマクロの肝は配列と抽選。職員リストで配置可能は1、配置不可能は0という入力をするというルールですが、各列の値をくっつけて配列に格納させています。
例えば１人目の佐藤さんの場合は「011109」で、１桁目が0なので夜勤不可、それ以外は配置可能、末尾２桁は行番号を示すのでこれは佐藤さんの情報であるということを意味します。
これを職員の人数分配列に格納させ、Randomizeで配列内をシャッフルして抽選します。この抽選のコードはVBAで配列をシャッフルする（要素をランダムに並べ替える）を参考にしました。
Module2 – 新規作成
新規シートを作成するマクロです。新規ボタンから実行します。
Sub 新規()
Dim thisYear As Variant '年
Dim thisMonth As Variant '月
Dim thisSheetName As String '元のシート名
Dim rowEnd As Integer '最終行
Dim colEnd As Integer '最終列
Dim fstWeekday As Variant '１日の曜日
'年月入力
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 & "月勤務表"
'最終行取得
Cells(9, 1).Select
rowEnd = Selection.End(xlDown).Row
'内容をリセット
Range(Cells(3, 3), Cells(rowEnd, 33)).ClearContents
Range(Cells(9, 3), Cells(rowEnd, 33)).Interior.ColorIndex = xlNone
Range(Cells(3, 1), Cells(rowEnd, 33)).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(3, 3).Value = "1"
Cells(3, 3).AutoFill Destination:=Range(Cells(3, 3), Cells(3, colEnd)), Type:=xlFillSeries
'曜日を入力しオートフィル
Cells(4, 3).Value = fstWeekday
Cells(4, 3).AutoFill Destination:=Range(Cells(4, 3), Cells(4, colEnd)), Type:=xlFillDays
'罫線を引く
Range(Cells(3, 1), Cells(rowEnd, colEnd)).Borders.LineStyle = xlContinuous
End Sub特に言うことはありません。閏年の判定については前に記事にしましたので説明は不要です。
強いて言うなら曜日は初日の分を取得し、あとはオートフィルで仕上げていること。それだけ。
Module3 – 配置ボタン
Sub 早出()
If Selection.Row >= 9 And Selection.Column >= 3 And Selection.Column <= 33 Then
Selection.Value = "早出"
Selection.Interior.Color = 16776960
End If
End Sub
Sub 遅出()
If Selection.Row >= 9 And Selection.Column >= 3 And Selection.Column <= 33 Then
Selection.Value = "遅出"
Selection.Interior.Color = 52479
End If
End Sub
Sub 日勤()
If Selection.Row >= 9 And Selection.Column >= 3 And Selection.Column <= 33 Then
Selection.Value = "日勤"
Selection.Interior.Color = 15773696
End If
End Sub
Sub 夜勤()
If Selection.Row >= 9 And Selection.Column >= 3 And Selection.Column <= 33 Then
Selection.Value = "夜勤"
Selection.Interior.Color = 65280
End If
End Sub
Sub 公休()
If Selection.Row >= 9 And Selection.Column >= 3 And Selection.Column <= 33 Then
Selection.Value = "公休"
Selection.Interior.ColorIndex = 0
End If
End Sub
Sub 年休()
If Selection.Row >= 9 And Selection.Column >= 3 And Selection.Column <= 33 Then
Selection.Value = "年休"
Selection.Interior.ColorIndex = 0
End If
End Sub
Sub 半年()
If Selection.Row >= 9 And Selection.Column >= 3 And Selection.Column <= 33 Then
Selection.Value = "半年"
Selection.Interior.ColorIndex = 0
End If
End Sub
Sub 明け()
If Selection.Row >= 9 And Selection.Column >= 3 And Selection.Column <= 33 Then
Selection.Value = "明け"
Selection.Interior.ColorIndex = 0
End If
End Sub
Sub 消去()
If Selection.Row >= 9 And Selection.Column >= 3 And Selection.Column <= 33 Then
Selection.Value = ""
Selection.Interior.Color = 16777215
End If
End Subこれも単純。配置名とセルの背景色を入れるだけ。念の為枠外を選択している場合は実行しないようにしています。下方については操作ミスは起こりにくいでしょうし、職員が増えた時に動作しなくなるので制限しています。
ThisWorkbook – ハイライト
予定を入力する際、日や職員を間違えて選択しやすいのでハイライト表示させます。
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())
'の条件で背景色を設定Excel/選択している行をハイライト表示する方法を参考にしています。
コメント
実用性のある素晴らしいVBA情報ありがとうございます。質問になりますが夜勤は1.5労働とし、基本的に２日連続で入り翌日は「明け」、その翌日は公休とするの条件に遅番を追加する場合はどうすればよろしいでしょうか?
佐々木真司 様
コメントありがとうございます。
autoMakingプロシージャの205行目にある”公休”を”遅出”に変えればできます。
公休か遅出のどちらかをランダムで配置という場合は、さらにひと手間が必要ですのでここでの説明は割愛します。
素晴らしいVBAですね。
初心者にはとてもありがたいです。
遅出の次の日は早出にしないということはできますでしょうか。
素晴らしい機能でした。
VBA初学者なので、ほとんど書いてあることが分からないのですが、少しずつコマンドを勉強しています。
遅出の次の日は、早出以外（日勤か遅出のランダム）としたいのですが、どうしたらよいでしょうか
山田義久 様
コメントありがとうございます。
遅出の次の日は早出以外とするのは可能です。
97行目からのForループが各配置の処理になるのですが、早出の処理はiが1の時に行われます。
149行目あたりに、iが1の場合、1列前のセルの値を確認し「遅出」だった場合はsetFlgをFalseにするという分岐を加えたらできます。
あまり難しくない処理なので、調べながらコードを書いてみてください。
ヒントとしましては、処理を行う行番号はsetRow、列番号はsetColで表すので、1列前のセルを参照する場合はsetCol – 1で表せます。
実用的な素晴らしい情報ありがとうございます。
質問ですが必ず3連勤「同じ時間を」入れたい場合はどうすればよろしいでしょうか？
コメントありがとうございます。
151行目と152行目がセルに入力するコードですので、翌日と翌々日の分も同時に入力するようにすればよいかと思います。
病院勤務表用のVBAを探していて、やっとで辿り着きました。細かい設定までしてあり、とても助かります。
質問なのですが、「早番」「遅番」をなくす事は可能でしょうか？
コメントありがとうございます。
VBA上で編集するのであれば、夜勤→公休→早出→遅出の順番で処理しているので、夜勤と公休だけ残して他を削除することでそのような仕様に変えることは可能です。
https://www.iehohs.com/excel-auto-shift4/
最新版の方であれば、早出と遅出の設定人数を0にすれば夜勤と公休のみの仕様に変えられます。