- 目的:Excelでシフト表を作成。
- 課題:条件通りのものを作ろうとすると時間がかかる。
- 解決策:VBAで条件に従い自動作成
- 成果物:excel-auto-shift.xlsm
※改良版を作成しています。下記リンクからどうぞ。

スクリーンショット


シフト表を作成する上での要件をまとめます。
- 早出、日勤、遅出、夜勤の4種類の配置がある
- 1日あたり夜勤は2人、それ以外は1人ずつを最低限配置する
- 夜勤は1.5労働とし、基本的に2日連続で入り翌日は「明け」、その翌日は公休とする
- 夜勤を連続で入れない場合は翌日を年次有給休暇(年休)を半日使用する「半年」、その翌日を公休とする
- 6日連続で勤務となった場合、公休を2日続けて取得する
- 役職や個人の都合により特定の配置にしかつけない場合、「職員リスト」シートで「0」を入力する
- 「職員リスト」では、1ヶ月あたりの夜勤の上限回数を指定する
操作について
上部に各種ボタンを配置しています。クリックするとマクロが動きます。
まず「新規」のボタンをクリックするとアクティブのシートを複製し、シフトをまっさらな状態にします。その際、年月を入力し、日数と曜日を取得します。
配置の書かれたボタンは、選択したセルにそれぞれの配置を入力することができます。希望休など予定が決まってるのでればあらかじめ入力しておきます。
実行ボタンを押すと、空いているセルに次々と配置を入れていきます。職員はランダムに選出され、既に予定が入っているところは避けます。また、既に定員分の入力がされている配置についてはスキップします。
これで決まっている予定を守りつつ最低限の配置がされます。あとは公休の日数を調整しながら、手動で配置をしていく感じです。
シフト作成作業の6割程度が自動化されるイメージです。公休の日数調整までやろうとすればできるのですが、勤務のバランスをとるのが難しいので、仕上げは人がやると割り切った方が効率的だという判断です。
VBA
まずは最も中心となるマクロから。これは実行ボタンを押すと行われます。
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 |
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 '6連勤カウント' 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という入力をするというルールですが、各列の値をくっつけて配列に格納させています。
例えば1人目の佐藤さんの場合は「011109」で、1桁目が0なので夜勤不可、それ以外は配置可能、末尾2桁は行番号を示すのでこれは佐藤さんの情報であるということを意味します。
これを職員の人数分配列に格納させ、Randomizeで配列内をシャッフルして抽選します。この抽選のコードはVBAで配列をシャッフルする(要素をランダムに並べ替える)を参考にしました。
新規作成
新規シートを作成するマクロです。新規ボタンから実行します。
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 |
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 '1日の曜日' '年月入力' 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 |
特に言うことはありません。閏年の判定については前に記事にしましたので説明は不要です。
強いて言うなら曜日は初日の分を取得し、あとはオートフィルで仕上げていること。それだけ。
各配置ボタン
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 |
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に次のコードを入れます。下部のコメント部分は条件付き書式に設定します。
1 2 3 4 5 6 7 |
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労働とし、基本的に2日連続で入り翌日は「明け」、その翌日は公休とするの条件に遅番を追加する場合はどうすればよろしいでしょうか?
佐々木真司 様
コメントありがとうございます。
autoMakingプロシージャの205行目にある”公休”を”遅出”に変えればできます。
公休か遅出のどちらかをランダムで配置という場合は、さらにひと手間が必要ですのでここでの説明は割愛します。
素晴らしいVBAですね。
初心者にはとてもありがたいです。
遅出の次の日は早出にしないということはできますでしょうか。
素晴らしい機能でした。
VBA初学者なので、ほとんど書いてあることが分からないのですが、少しずつコマンドを勉強しています。
遅出の次の日は、早出以外(日勤か遅出のランダム)としたいのですが、どうしたらよいでしょうか
山田義久 様
コメントありがとうございます。
遅出の次の日は早出以外とするのは可能です。
97行目からのForループが各配置の処理になるのですが、早出の処理はiが1の時に行われます。
149行目あたりに、iが1の場合、1列前のセルの値を確認し「遅出」だった場合はsetFlgをFalseにするという分岐を加えたらできます。
あまり難しくない処理なので、調べながらコードを書いてみてください。
ヒントとしましては、処理を行う行番号はsetRow、列番号はsetColで表すので、1列前のセルを参照する場合はsetCol – 1で表せます。
実用的な素晴らしい情報ありがとうございます。
質問ですが必ず3連勤「同じ時間を」入れたい場合はどうすればよろしいでしょうか?
コメントありがとうございます。
151行目と152行目がセルに入力するコードですので、翌日と翌々日の分も同時に入力するようにすればよいかと思います。