Excelでシフトを自動作成するマクロを作成しました。
生業の方でできないかという提案があり、作ったものをサンプル化しました。
これまで自分がやってきたことの集大成的なマクロになりました。実用性があるかと言われれば断言できませんが、応用すればそれなりのものにはなるんじゃないですかね。
↓作り直したんで、この記事を既に読んだ方はこちらへどうぞ！
コンテンツ
サンプルデータ
こちらがサンプルファイルです。悪意のあるソースは含まれておりませんのでご安心を。
スクリーンショットにあるようなシフト表を作成します。要件としましては、
- 早出、日勤、遅出、夜勤の４種類の配置がある
- １日あたり夜勤は２人、それ以外は１人ずつを最低限配置する
- 夜勤は1.5労働とし、基本的に２日連続で入り翌日は「明け」、その翌日は公休とする
- 夜勤を連続で入れない場合は翌日を年次有給休暇（年休）を半日使用する「半年」、その翌日を公休とする
- ６日連続で勤務となった場合、公休を２日続けて取得する
- 役職や個人の都合により特定の配置にしかつけない場合、「職員リスト」シートで「0」を入力する
- 「職員リスト」では、１ヶ月あたりの夜勤の上限回数を指定する
ってな感じです。
操作について
上部に各種ボタンを配置しています。クリックするとマクロが動きます。
まず「新規」のボタンをクリックするとアクティブのシートを複製し、シフトをまっさらな状態にします。その際、年月を入力し、日数と曜日を取得します。
配置の書かれたボタンは、選択したセルにそれぞれの配置を入力することができます。希望休など予定が決まってるのでればあらかじめ入力しておきます。
実行ボタンを押すと、空いているセルに次々と配置を入れていきます。職員はランダムに選出され、既に予定が入っているところは避けます。また、既に定員分の入力がされている配置についてはスキップします。
これで決まっている予定を守りつつ最低限の配置がされます。あとは公休の日数を調整しながら、手動で配置をしていく感じです。
シフト作成作業の６割程度が自動化されるイメージです。公休の日数調整までやろうとすればできるのですが、勤務のバランスをとるのが難しいので、仕上げは人がやると割り切った方が効率的だという判断です。
VBA
まずは最も中心となるマクロから。これは実行ボタンを押すと行われます。
Sub autoMaking()
Dim thisSheetName As String '当月シフトのシート（マクロの実行シート）
Dim memSheetName As String '常勤リストのシート
Dim startCol As Integer '選択セルの列番号（この列からマクロ実行）
Dim endCol As Integer '最終日数の列番号
Dim memberRow As Integer 'シフトの氏名
Dim memLengeth As Variant '職員数（常勤）
Dim allRow As Integer '専任も含めた職員名の最終行
Dim nLimit As Integer '夜勤の上限回数
Dim renLimit As Integer '連勤の上限回数
startCol = 3
startRow = 9
Cells(startRow - 6, startCol).Select
endCol = 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 = startCol To endCol
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
Call haichiPro(member, memLength, memberRow, memSheetName, haichiArr, codeArr, clrArr, cntArr, startRow, startCol, i, endCol, nLimit)
Next
End Sub
Sub haichiPro(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 startCol As Integer, _
ByVal setCol As Integer, _
ByVal endCol As Integer, _
ByVal nLimit As Integer)
Dim setRow As Integer
Dim renCnt As Variant
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 randomPro(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 endCol
If Cells(setRow, k).Value = "" Then
Cells(setRow, k).Value = "公休"
Exit For
End If
Next
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 <> endCol 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 <> endCol 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 randomPro(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 < endCol - 1 Then
Cells(setRow, setCol + 2).Value = "明け"
End If
If setCol < endCol - 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 < endCol - 1 Then
Cells(setRow, setCol + 2).Value = "公休"
End If
End If
End If
Next
End If
End Sub
Sub randomPro(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で配列をシャッフルする（要素をランダムに並べ替える）を参考にしました。
新規作成
新規シートを作成するマクロです。新規ボタンから実行します。
Sub reset()
'年月入力
thisYear = Application.InputBox("西暦を半角4桁の数字で入力してください。")
If thisYear = False Then
MsgBox ("キャンセルが押されました。" _
& vbCrLf & "作業を中止します。")
Exit Sub
End If
If Not Len(thisYear) = 4 Then
MsgBox ("西暦は4桁で入力してください。" _
& vbCrLf & "作業を中止します。")
Exit Sub
End If
thisMonth = Application.InputBox("月を半角で入力してください。（1〜12）")
If thisMonth = False Then
MsgBox ("キャンセルが押されました。" _
& vbCrLf & "作業を中止します。")
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 & "月勤務表"
startCol = 3
Cells(9, 1).Select
allRow = Selection.End(xlDown).Row
Range(Cells(3, 3), Cells(allRow, 33)).ClearContents
Range(Cells(9, 3), Cells(allRow, 33)).Interior.ColorIndex = xlNone
Range(Cells(3, 1), Cells(allRow, 33)).Borders.LineStyle = xlLineStyleNone
If thisMonth = 4 Or thisMonth = 6 Or thisMonth = 9 Or thisMonth = 11 Then
endCol = 32
ElseIf thisMonth = 2 Then
If Not thisYear Mod 400 = 0 Then
If thisYear Mod 100 = 0 Then
endCol = 30
ElseIf thisYear Mod 4 = 0 Then
endCol = 31
Else
endCol = 30
End If
End If
Else
endCol = 33
End If
'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, endCol)), Type:=xlFillSeries
Cells(4, 3).Value = fstWeekday
Cells(4, 3).AutoFill Destination:=Range(Cells(4, 3), Cells(4, endCol)), Type:=xlFillDays
Range(Cells(3, 1), Cells(allRow, endCol)).Borders.LineStyle = xlContinuous
End Sub
特に言うことはありません。閏年の判定については前に記事にしましたので説明は不要です。
強いて言うなら曜日は初日の分を取得し、あとはオートフィルで仕上げていること。それだけ。
各配置ボタン
Sub hayade()
If Selection.Row >= 9 And Selection.Column >= 3 And Selection.Column <= 33 Then
Selection.Value = "早出"
Selection.Interior.Color = 16776960
End If
End Sub
Sub osode()
If Selection.Row >= 9 And Selection.Column >= 3 And Selection.Column <= 33 Then
Selection.Value = "遅出"
Selection.Interior.Color = 52479
End If
End Sub
Sub nikkin()
If Selection.Row >= 9 And Selection.Column >= 3 And Selection.Column <= 33 Then
Selection.Value = "日勤"
Selection.Interior.Color = 15773696
End If
End Sub
Sub yakin()
If Selection.Row >= 9 And Selection.Column >= 3 And Selection.Column <= 33 Then
Selection.Value = "夜勤"
Selection.Interior.Color = 65280
End If
End Sub
Sub kokyu()
If Selection.Row >= 9 And Selection.Column >= 3 And Selection.Column <= 33 Then
Selection.Value = "公休"
Selection.Interior.ColorIndex = 0
End If
End Sub
Sub nenkyu()
If Selection.Row >= 9 And Selection.Column >= 3 And Selection.Column <= 33 Then
Selection.Value = "年休"
Selection.Interior.ColorIndex = 0
End If
End Sub
Sub hannen()
If Selection.Row >= 9 And Selection.Column >= 3 And Selection.Column <= 33 Then
Selection.Value = "半年"
Selection.Interior.ColorIndex = 0
End If
End Sub
Sub ake()
If Selection.Row >= 9 And Selection.Column >= 3 And Selection.Column <= 33 Then
Selection.Value = "明け"
Selection.Interior.ColorIndex = 0
End If
End Sub
Sub del()
If Selection.Row >= 9 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())
' の条件で背景色を設定
Excel/選択している行をハイライト表示する方法を参考にしています。
そんな感じです。以上。
続編があります。こっちの方がおすすめです。
実用性のある素晴らしいVBA情報ありがとうございます。質問になりますが夜勤は1.5労働とし、基本的に２日連続で入り翌日は「明け」、その翌日は公休とするの条件に遅番を追加する場合はどうすればよろしいでしょうか?
佐々木真司 様
コメントありがとうございます。
autoMakingプロシージャの205行目にある”公休”を”遅出”に変えればできます。
公休か遅出のどちらかをランダムで配置という場合は、さらにひと手間が必要ですのでここでの説明は割愛します。
素晴らしいVBAですね。
初心者にはとてもありがたいです。
遅出の次の日は早出にしないということはできますでしょうか。
素晴らしい機能でした。
VBA初学者なので、ほとんど書いてあることが分からないのですが、少しずつコマンドを勉強しています。
遅出の次の日は、早出以外（日勤か遅出のランダム）としたいのですが、どうしたらよいでしょうか
山田義久 様
コメントありがとうございます。
遅出の次の日は早出以外とするのは可能です。
97行目からのForループが各配置の処理になるのですが、早出の処理はiが1の時に行われます。
149行目あたりに、iが1の場合、1列前のセルの値を確認し「遅出」だった場合はsetFlgをFalseにするという分岐を加えたらできます。
あまり難しくない処理なので、調べながらコードを書いてみてください。
ヒントとしましては、処理を行う行番号はsetRow、列番号はsetColで表すので、1列前のセルを参照する場合はsetCol – 1で表せます。