このブログの人気記事は相変わらずシフト表自動作成マクロに関する記事です。よっぽど勤務を組むのに苦労している人が多いようです。
Excelのセル、すなわちオブジェクト上で情報の書き込みを行うと結構処理が遅くなります。
そういう時は変数や配列を使って処理を行うと速くなります。前回作ったものも配列を使ってましたが、条件を満たす度にオブジェクトに書き込んでいたため、完了までに時間がかかってました。
また、複数の配列を使ってインデックス番号で配列同士を関連付けしていましたが、配列がたくさんできすぎてややこしくなっていました。
そこで勤務表や設定表を二次元配列に格納して配列上ですべて処理を行い、オブジェクトへの書き込みは１回にまとめて処理を高速化しました。
※改良に改良を重ねた最新版は下のリンクからどうぞ。
プログラムの内容
サンプルデータはこちら。
こんな感じのレイアウトに作り変えました。
メインとなる勤務表、その右に職員の１ヶ月分の集計、下には各日付の配置の集計、集計表の右に職員ごとに配置の有無を設定する表、さらにその右上に条件を設定する表があります。
新規シート
新規シートボタンを押すと西暦と月を入力し、内容がリセットされて日付と曜日を整えられた新しいシートができあがります。
職員追加
職員追加ボタンを押すと最後の行に追加します。集計表と設定表の数式や値は自動で入力され、氏名は１列目に入れたら集計表と設定表にも自動で表示されます。
マクロの設定
勤務表の各セルはドロップダウンリストでの選択式です。
「夜」「早」「遅」が入力されるとセルの背景色が変わるように条件付き書式を設定しています。
自動入力では既に入力されたところはセットしないようにしているため、希望休や勤務希望をあらかじめ入力した上でマクロを実行します。
設定表では各配置の人数を決められます。夜勤がない場合は人数を0にしておけば処理は行われません。
各職員の各配置について、入力の対象であれば「1」を入力します。
右の条件はそれぞれ以下のような内容です。
| 夜勤労働数 | 1労働, 1.5労働, 2労働 | 夜勤労働数によって処理が変わります |
| 連続夜勤 | あり, なし | 1労働夜勤における連続夜勤の設定です 値にかかわらず、1.5労働の場合はあり、2労働の場合はなしに変更されます |
| 連続夜勤後連休 | あり, なし | 1労働夜勤における、連続夜勤の後は連休にする設定です 1.5労働と2労働の場合は明け→休みとなるためこの設定は無効です |
| 遅→早禁止 | あり, なし | 遅出の翌日が早出になることを禁止します ありで禁止、なしで遅→早の配置を許可します |
2021年4月17日機能追加：公休のON/OFF
この記事を投稿した時点のものと変更している点があります。
公休の下が0か1の選択式になっています。他の項目では人数の設定ですが、ここでは1ならON、0ならOFFの切り替えです。
公休の振り分けを行わない場合は0にすればスキップされます。ただし、夜勤の翌日以降の公休については行われますので注意です。
マクロの実行
自動入力ボタンを押すと一瞬でできあがります。前回のものとは比にならない速度です。
プログラミング
VBA
'共通変数
Dim rowStart As Integer '勤務表の開始行
Dim rowEnd As Integer '勤務表の最終行
Dim colStart As Integer '勤務表の開始列
Dim colEnd As Integer '勤務表の最終行
Dim headRow As Integer '日付のある行
Dim cfgCol As Integer '設定表の開始列
Dim cfgColEnd As Integer '設定表の最終列
Sub 基本設定(rowStart, rowEnd, colStart, colEnd, headRow, cfgCol, cfgColEnd)
rowStart = 4 '勤務表の開始行
colStart = 3 '勤務表の開始列
headRow = 2 '日付のある行
cfgCol = 43 '設定表の開始列
Cells(headRow, 1).Select
rowEnd = Selection.End(xlDown).Row '勤務表の最終行を取得
colEnd = Selection.End(xlToRight).Column '勤務表の最終列を取得
Cells(headRow, cfgCol).Select
cfgColEnd = Selection.End(xlToRight).Column '設定表の最終列を取得
End Sub
Sub 自動入力()
Call 基本設定(rowStart, rowEnd, colStart, colEnd, headRow, cfgCol, cfgColEnd)
Dim maxHol As Integer '公休日数
Dim holStr As String '「公休」文字列
Dim holiStr As String '「HOLI」文字列（自動で入力したことを表す仮表記）
Dim aveHol As Integer '1日あたりの公休人数
Dim tblArr() As String '勤務表の配列
Dim cfgArr() As Integer '設定の配列（各配置の設定）
Dim cfg2Arr() As String '設定の配列（夜勤の労働数などの条件）
Dim cntArr() As Variant '各配置の人数
Dim rowArr() As Integer '行番号シャッフル用
Dim arrCnt As Integer '配列用カウンタ
Dim blankArr() As Integer '公休セット時の空き列番号
Dim blankCnt As Integer '空き列番号の配列用カウンタ
Dim holiArr() As Integer '公休セット時の「HOLI」列番号
Dim holiCnt As Integer 'HOLI列番号の配列用カウンタ
Dim koukyuStr As String '公休文字列
Dim yasumiStr As String '非常勤休み文字列
Dim pNenStr As String '午後年休文字列
Dim pHolStr As String '非常勤午後休文字列
Dim akeStr As String '明け文字列
Dim roudou As String '夜勤の労働数
Dim renzokuFlg As Boolean '連続夜勤フラグ
Dim renkyuflg As Boolean '連続夜勤後連休フラグ
Dim osohayaFlg As Boolean '遅→早禁止フラグ
Dim thisSheetName As String '元のシート名
Dim setFlg As Boolean 'セットフラグ
koukyuStr = "公休" '公休の表記
yasumiStr = "休" '非常勤職員の休み表記
pNenStr = "P年" '常勤職員の夜勤明けは午後年休
pHolStr = "P休" '非常勤職員の夜勤明けは午後休
akeStr = "明け" '明けの表記を指定
'条件の値を配列にセット
ReDim cfg2Arr(3)
For i = 0 To 3
cfg2Arr(i) = Cells(headRow, cfgColEnd + 2 + i).Value
Next
'夜勤の労働数をセット
roudou = cfg2Arr(0)
'連続夜勤フラグ
Select Case cfg2Arr(1)
Case "あり"
renzokuFlg = True
Case "なし"
renzokuFlg = False
End Select
'連続夜勤フラグを1.5労働の場合はTrue、2労働夜勤の場合はFalseに強制変更
Select Case roudou
Case "1.5労働"
renzokuFlg = True
Case "2労働"
renzokuFlg = False
End Select
'連続夜勤後連休フラグ（1労働夜勤の場合のみ有効）
Select Case cfg2Arr(2)
Case "あり"
renkyuflg = True
Case "なし"
renkyuflg = False
End Select
'遅→早禁止フラグ
Select Case cfg2Arr(3)
Case "あり"
osohayaFlg = True
Case "なし"
osohayaFlg = False
End Select
'最終列から公休日数を決定
Select Case colEnd
Case 33
maxHol = 10
Case 30
maxHol = 8
Case Else
maxHol = 9
End Select
'シートを複製
thisSheetName = ActiveSheet.Name
Worksheets(thisSheetName).Copy Before:=Worksheets(thisSheetName)
ActiveSheet.Name = thisSheetName & "作成済"
'勤務表を配列に格納
ReDim tblArr(rowEnd - rowStart, colEnd - colStart)
For c = 0 To colEnd - colStart
For r = 0 To rowEnd - rowStart
tblArr(r, c) = Cells(rowStart + r, colStart + c).Value
Next r
Next c
'設定表を配列に格納
ReDim cfgArr(rowEnd - rowStart, cfgColEnd - cfgCol)
For c = 0 To cfgColEnd - cfgCol
For r = 0 To rowEnd - rowStart
cfgArr(r, c) = Cells(rowStart + r, cfgCol + c).Value
Next r
Next c
'配置名と人数を配列に格納
ReDim cntArr(1, cfgColEnd - cfgCol)
For c = 0 To cfgColEnd - cfgCol
For r = 0 To 1
cntArr(r, c) = Cells(headRow + r, cfgCol + c).Value
Next r
Next c
'セット開始
'0:夜 1:早 2:遅
For i = 0 To 2
'設定表で1になっている行番号を配列にセット
arrCnt = 0
ReDim rowArr(arrCnt)
For r = 0 To UBound(cfgArr, 1)
If cfgArr(r, i) = 1 Then
ReDim Preserve rowArr(arrCnt)
rowArr(arrCnt) = r
arrCnt = arrCnt + 1
End If
Next
'配列をシャッフルしカウンタをリセット
Call シャッフル(rowArr(), arrCnt)
'各列を処理
For c = 0 To UBound(tblArr, 2)
setCnt = cntArr(1, i) '人数をカウンタにセット
shuffleFlg = False 'シャッフルフラグ（シャッフルは1列あたり1回まで）
'各行を処理
For r = 0 To UBound(tblArr, 1)
'既にセットされていたらカウンタを減らす
If tblArr(r, c) Like cntArr(0, i) & "*" Then
setCnt = setCnt - 1
If setCnt = 0 Then
Exit For
End If
End If
Next r
'カウンタが0になるまでセット
Do While setCnt > 0
'複数配置する場合はナンバリングする
Select Case cntArr(1, i)
Case 1
setStr = cntArr(0, i)
Case Else
setStr = cntArr(0, i) & setCnt
End Select
'対象セルが空白の場合はセット
If tblArr(rowArr(arrCnt), c) = "" Then
Select Case i
Case 0 '夜勤処理
'夜勤は翌日以降の状況を確認してからセット
setFlg = False
Select Case c
Case UBound(tblArr, 2) '最終列ならば気にする必要ないのでセット
setFlg = True
Case Else
If tblArr(rowArr(arrCnt), c + 1) = "" Then '翌日が空白ならセット
setFlg = True
End If
End Select
If setFlg = True Then
'セットしカウンタを減らす
tblArr(rowArr(arrCnt), c) = setStr
setCnt = setCnt - 1
'連続処理
If c <> UBound(tblArr, 2) Then
'常勤か非常勤かで休みの文字列を変更
Select Case cfgArr(rowArr(arrCnt), 3)
Case 1
holStr = koukyuStr
Case 0
holStr = yasumiStr
End Select
Select Case renzokuFlg
Case True '連続夜勤ありの場合
'翌日の夜勤の配置状況を確認
setCnt2 = cntArr(1, i)
For n = 0 To UBound(tblArr, 1)
If tblArr(n, c + 1) Like cntArr(0, i) & "*" Then
setCnt2 = setCnt2 - 1
If setCnt2 = 0 Then
Exit For
End If
End If
Next n
If setCnt2 >= 1 Then
'カウンタが残って入れば連続夜勤設定
Select Case cntArr(1, i)
Case 1
setStr = cntArr(0, i)
Case Else
setStr = cntArr(0, i) & setCnt2
End Select
tblArr(rowArr(arrCnt), c + 1) = setStr
'翌々日以降の処理
If c <> UBound(tblArr, 2) - 1 Then
Select Case roudou
Case "1.5労働"
'明け→休みにする
tblArr(rowArr(arrCnt), c + 2) = akeStr
If c <> UBound(tblArr, 2) - 2 Then
tblArr(rowArr(arrCnt), c + 3) = holStr
End If
Case "1労働"
tblArr(rowArr(arrCnt), c + 2) = holStr
'連休フラグが立っていれば連休にする
If renkyuflg = True And c <> UBound(tblArr, 2) - 2 Then
tblArr(rowArr(arrCnt), c + 3) = holStr
End If
End Select
End If
Else
'カウンタが0の場合は連続夜勤にしない
Select Case roudou
Case "1.5労働" '1.5労働の場合は明けに午後年休（非常勤は午後休）を使用
Select Case cfgArr(rowArr(arrCnt), 3)
Case 1
tblArr(rowArr(arrCnt), c + 1) = pNenStr
Case 0
tblArr(rowArr(arrCnt), c + 1) = pHolStr
End Select
'翌々日は休み'
If c <> UBound(tblArr, 2) - 1 Then
tblArr(rowArr(arrCnt), c + 2) = holStr
End If
Case "1労働" '翌日は休み
tblArr(rowArr(arrCnt), c + 1) = holStr
End Select
End If
Case False '連続夜勤なしの場合
Select Case roudou
Case "2労働" '明け→休みにする
tblArr(rowArr(arrCnt), c + 1) = akeStr
If c <> UBound(tblArr, 2) - 1 Then
tblArr(rowArr(arrCnt), c + 2) = holStr
End If
Case "1労働" '翌日は休み
tblArr(rowArr(arrCnt), c + 1) = holStr
End Select
End Select
End If
End If
Case 1 '早出処理
If osohayaFlg = True Then '遅→早が禁止の場合
setFlg = False
Select Case c
Case 0 '最初の列であれば気にする必要がないためセット
setFlg = True
Case Else '前日が遅出の場合はセットしない
If Not tblArr(rowArr(arrCnt), c - 1) Like cntArr(0, 2) & "*" Then
setFlg = True
End If
End Select
If setFlg = True Then '前日が遅出でなければセット
tblArr(rowArr(arrCnt), c) = setStr
setCnt = setCnt - 1
End If
Else '遅→早が禁止でない場合はセット
tblArr(rowArr(arrCnt), c) = setStr
setCnt = setCnt - 1
End If
Case 2 '遅出処理
If osohayaFlg = True Then '遅→早が禁止の場合
setFlg = False
Select Case c
Case UBound(tblArr, 2) '最終列の場合は気にする必要がないためセット
setFlg = True
Case Else '翌日が早出の場合はセットしない
If Not tblArr(rowArr(arrCnt), c + 1) Like cntArr(0, 1) & "*" Then
setFlg = True
End If
End Select
If setFlg = True Then '翌日が早出でなければセット
tblArr(rowArr(arrCnt), c) = setStr
setCnt = setCnt - 1
End If
Else '遅→早が禁止でない場合はセット
tblArr(rowArr(arrCnt), c) = setStr
setCnt = setCnt - 1
End If
End Select
End If
'配列用カウンタが最後までいったらシャッフルし直し
If arrCnt = UBound(rowArr()) Then
Call シャッフル(rowArr(), arrCnt)
Select Case shuffleFlg '1列あたりシャッフルは1回まで
Case False
shuffleFlg = True
Case True
setCnt = 0
End Select
Else
arrCnt = arrCnt + 1
End If
Loop
Next c
'夜勤処理後に公休処理
If cntArr(1, 3) = 1 And i = 0 Then
holStr = koukyuStr
holiStr = "HOLI"
arrCnt = 0
'公休配置の職員を配列に格納
ReDim rowArr(arrCnt)
For r = 0 To UBound(cfgArr, 1)
If cfgArr(r, 3) = 1 Then
ReDim Preserve rowArr(arrCnt)
rowArr(arrCnt) = r
arrCnt = arrCnt + 1
End If
Next r
Call シャッフル(rowArr(), arrCnt)
'1日あたりの公休人数を算出
aveHol = Round((maxHol * UBound(rowArr) + 1) / UBound(tblArr, 2), 0)
'各列を処理
For c = 0 To UBound(tblArr, 2)
shuffleFlg = False
setCnt = aveHol
Do While setCnt > 0
If tblArr(rowArr(arrCnt), c) = "" Then
tblArr(rowArr(arrCnt), c) = holiStr '希望休と区別にするために仮で「HOLI」とセット
setCnt = setCnt - 1
End If
'配列用カウンタが最後までいったらシャッフルし直し
If arrCnt = UBound(rowArr) Then
Call シャッフル(rowArr(), arrCnt)
Select Case shuffleFlg
Case False
shuffleFlg = True
Case True
setCnt = 0
End Select
Else
arrCnt = arrCnt + 1
End If
Loop
Next c
'公休をチェック
For n = 0 To UBound(rowArr)
setCnt = 0
blankCnt = 0
ReDim blankArr(blankCnt)
holiCnt = 0
ReDim holiArr(holCnt)
For c = 0 To UBound(tblArr, 2)
Select Case tblArr(rowArr(n), c)
Case holStr '公休の場合（希望休や夜勤後の休み）
setCnt = setCnt + 1
Case holiStr 'HOLIの場合（公休日数オーバーの場合は削除の対象）
setCnt = setCnt + 1
ReDim Preserve holiArr(holiCnt)
holiArr(holiCnt) = c
holiCnt = holiCnt + 1
Case "" '空白の場合（公休日数が足りない場合は追加の対象）
ReDim Preserve blankArr(blankCnt)
blankArr(blankCnt) = c
blankCnt = blankCnt + 1
End Select
Next c
Select Case setCnt
Case Is < maxHol '公休日数が足りない場合
Call シャッフル(blankArr(), arrCnt)
Do While setCnt < maxHol
tblArr(rowArr(n), blankArr(arrCnt)) = holiStr
setCnt = setCnt + 1
If arrCnt = UBound(blankArr) Then
setCnt = maxHol '空白列がない場合はスキップする
Else
arrCnt = arrCnt + 1
End If
Loop
Case Is > maxHol '公休日数がオーバーしている場合
Call シャッフル(holiArr(), arrCnt)
Do While setCnt > maxHol
tblArr(rowArr(n), holiArr(arrCnt)) = ""
setCnt = setCnt - 1
If arrCnt = UBound(holiArr) Then
setCnt = maxHol 'HOLIがない場合はスキップする
Else
arrCnt = arrCnt + 1
End If
Loop
End Select
Next n
'HOLIを公休に変換
For r = 0 To UBound(tblArr, 1)
For c = 0 To UBound(tblArr, 2)
If tblArr(r, c) = holiStr Then
tblArr(r, c) = holStr
End If
Next c
Next r
End If
Next i
'配列を勤務表にセットし処理完了
Range(Cells(rowStart, colStart), Cells(rowEnd, colEnd)).Value = tblArr()
Cells(rowStart, colStart).Select
MsgBox "処理完了"
End Sub
Sub シャッフル(ByRef myArr() As Integer, ByRef arrCnt As Integer)
'配列の順番をシャッフルして返す
For i = 0 To UBound(myArr)
Randomize
rn = Int(UBound(myArr) * Rnd)
tmp = myArr(i)
myArr(i) = myArr(rn)
myArr(rn) = tmp
Next
'配列用カウンタをリセット
arrCnt = 0
End Sub
Sub 新規()
Call 基本設定(rowStart, rowEnd, colStart, colEnd, headRow, cfgCol, cfgColEnd)
Dim thisYear As Variant '年
Dim thisMonth As Variant '月
Dim thisSheetName As String 'シート名
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(headRow, 1).Value = thisYear & "年"
Cells(headRow, 2).Value = thisMonth & "月"
'内容をクリア
Range(Cells(headRow, colStart), Cells(rowEnd, colEnd)).ClearContents
'月から最終列を決定
Select Case thisMonth
Case 4, 6, 9, 11
colEnd = 32
Case 2
If 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(headRow, colStart).Value = "1"
Cells(headRow, colStart).AutoFill Destination:=Range(Cells(headRow, colStart), Cells(headRow, colEnd)), Type:=xlFillSeries
Cells(headRow + 1, colStart).Value = fstWeekday
Cells(headRow + 1, colStart).AutoFill Destination:=Range(Cells(headRow + 1, colStart), Cells(headRow + 1, colEnd)), Type:=xlFillDays
Cells(rowStart, colStart).Select
End Sub
Sub 職員追加()
Call 基本設定(rowStart, rowEnd, colStart, colEnd, headRow, cfgCol, cfgColEnd)
Dim shukeiCol As Integer '集計表の開始列
shukeiCol = 35
'行を追加し上の行をコピペ
Rows(rowEnd + 1).Insert
Range(Cells(rowEnd, shukeiCol), Cells(rowEnd, cfgColEnd)).Copy
Range(Cells(rowEnd + 1, shukeiCol), Cells(rowEnd + 1, cfgColEnd)).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
'設定表の値を0にする
For i = cfgCol To cfgColEnd
Cells(rowEnd + 1, i).Value = 0
Next
Cells(rowEnd + 1, 1).Select
End Subすべて１つのモジュールにまとめました。
ハイライトのこととかは前回やったので割愛します。
二次元配列への格納
二次元配列へ格納するには、配列をVariant型で宣言しておき、Rangeメソッドで指定して範囲を代入すれば一発で格納できます。
ただ、この場合だとデータ型を指定できないため、それにより不都合がある場合は今回のようにループで１つずつ格納していくことをおすすめします。そんなに時間はかかりません。
今回の場合だと、空白セルは””で格納してほしいところがEmpty 値になっちゃうのがいやだったので、配列をString型で宣言してループで格納しました。
コメント
こんにちは。
稼働日と非稼働日で配置人数を変えたい場合に良い方法はありませんか？
例えば、平日は、2人、休日は、3人等。
コメントありがとうございます。
Excel上で完結させる方法としては、基本の人数設定を2人にしておき、勤務表下部の人数追加設定で必要な日だけ1人追加するというやり方が簡単です。
ご教示いただきありがとうございます。素人な質問で申し訳ないですが勤務表下部の人数追加設定の方法がわかりません。。ご教示いただけないでしょうか？
コメントありがとうございます。
例えば、夜勤の人数が１人設定の場合では各日に１人夜勤を配置するのですが、人数追加設定で１と入力した日については、その日は夜勤を＋１人として合計２人配置することになります。
早々のご回答ありがとうございます。
追加したい日の集計部分に1と入れる認識であっていますか？
先日コメントいただいた大館様でしたか。
その時のコメントで「勤務表下部の人数追加設定」と申しておりましたが、これは別のところで作ったものの仕様で、ここで公開しているものでは未実装でした。失礼いたしました。
参考までに、その仕様では勤務表の下部に集計表の他に人数追加用の表があり、数字を入れることで配置人数を増やせるというものです。
VBAでは138行目のsetCntに人数を入れる際に、その表の値もプラスするという形で人数を変更していました。
ご回答いただきありがとうございます。大変おこがましいお願いですが実装したものを送っていただくことは、可能でしょうか？
恐れ入りますが、お送りすることはできかねます。
この記事を参考にしてご自身で作成したり改造するのは応援するのですが、コードの書き方を伝えるなど直接的な支援はしておりません。
もしマクロの作成依頼をされるのであれば、下記リンクのページ内にあるクラウドソーシング（ランサーズ or クラウドワークス）からご依頼ください。
https://www.iehohs.com/about/
ありがとうございます。
参考にしながら自作していきます。