【Excel VBA】シフト自動作成マクロを作り直しました

前にExcelでシフト自動作成マクロを作りました。現在のところこのブログで最も見られている記事で、相当シフト作成に苦労されているところが多いんだなと見受けます。

内容的にはあらかじめ予定をセットしておいてプログラムを走らせたら、ランダムで配置していくというもの。

複雑な勤務体系の場合はどうしても勤務や休みに偏りが出てしまうのですが、それを機械任せにすることで公平性をもたせるという目的です。

ただ、イマイチだったのがランダムゆえの偏りが発生してしまいがちなのが気になっていました。毎回抽選し直していたので、連続で同じ人が同じ配置についてしまうことがしばしば。

そこで、抽選する配列には行番号や列番号を入れておき、一巡してからシャッフルするという風に作り変えました。

※改良に改良を重ねた最新版は下のリンクからどうぞ。

スポンサーリンク

プログラムの内容

こちらがサンプルのデータです。

https://www.iehohs.com/files/excel-auto-shift2.zip

フォーマット自体もかなり変えました。

前回は設定用のシートを別に設けていましたが、シフト表の右側にまとめました(以下、設定リストとよびます)。シートが別だと設定するのを忘れてしまいがちなので、この方がミスが少ないですよね。

設定リストの早出、遅出、夜勤が入っているセルの色をセットするようにしています。これでお好みの色にすることができます。また、その上の人数と書かれた行の数字の数だけ配置します。

実行ボタンを押した後です。割とバランスよく並んでいるかと思います。

要件としましては、今回は夜勤を1労働としてカウント、なるべく連続で入るようにして、その場合は2連休を配置するようにしました。

前回は労基的な意味で7連勤にならないようにしていましたが、今回は廃止しました。いろいろ方法を考えましたが、ループしてしまう可能性が少しでもあったので。バグをなくすことを最優先に考えました。

プログラミング

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())
'の条件で背景色を設定

コメント

  1. 山本 より:

    夜勤の人数の件ですが、たとえば、その日に夜勤入と夜勤明けがありますが、設定で夜勤を2にすると夜勤入が二人重なるため、夜勤明けと夜勤入りができません。
    当日に夜勤明けと夜勤入りを分けることは可能ですか?

    • オクタ゛シヨウヘイ より:

      コメントありがとうございます。
      すみません、夜勤明けと夜勤入りを分けるという意味があまりわかりません。
      夜勤入りの翌日は夜勤明けにするということでしょうか。
      それでしたら前バージョンでやっておりますので、そちらを参考にしてください。
      https://www.iehohs.com/excel-auto-shift/

  2. 山本 より:

    返答ありがとうございます。
    説明が悪くてすみません、早出・遅出・夜勤の色付きのところの数字を夜勤を2にした場合に夜勤入りのスタッフが同日に夜勤入りが2人になり、次の日はその2人が夜勤明けになるため、夜勤入も含めた場合は、当日は夜勤入1、夜勤明1 で夜勤は数通りに2で合計されますが、夜勤明けが2人になって夜勤入りがない状態になりますので、どのようにしたらよいでしょうか?よろしくお願いいたします。
     12月 1日   2日
        夜勤入  夜勤明
        夜勤入  夜勤明
        早出   早出
        
        早出1  早出1
        夜勤2  夜勤2
             ↑設定どおり夜勤は2になりますが、夜勤入がないためその日に夜勤に入る人がいない。

    • オクタ゛シヨウヘイ より:

      既にアレンジして「夜勤入」と「夜勤明」がランダムで入るようにされているということですかね。
      元のプログラムとしては設定リストのところでR4C42のセルが「夜勤」となっていれば、既に入っている人数の確認は「夜勤」の文字列が入っている時のみカウンタを減らすので「夜勤入」および「夜勤明」どちらの場合でもカウンタは減らないはずです。
      単純に「夜勤入」を設定した人数分配置したいのであればR4C42のセルを「夜勤入」に変更し、「夜勤入」が配置された翌日は「夜勤明」を設定するようにコードを書き足せばOKかと思います。
      ちなみに「夜勤入」の翌日が必ず「夜勤明」になるということは2労働制の夜勤でしょうか。

  3. 山本 より:

    夜分遅くに何度も返答ありがとうございます。
    そうです、2労働制の夜勤です。コードはどのように書き足せばよろしいですか?

    • オクタ゛シヨウヘイ より:

      「夜勤入」が入力されたらその次の列に「夜勤明」が入るようにコードを記述すればいいと思います。
      具体的なコードについてはコメント欄でお伝えしないことにしているので、ご自身で頑張ってコーディングしてみてください。
      どうしてもわからないのであれば、ランサーズあるいはクラウドワークスよりご依頼ください。

  4. 山口悟 より:

    まさに私が欲しかった情報があって助かりました。
    条件を一つ追加したい時などはどうやって記述すればいいでしょうか。
    当直回数を本人の希望数にしたいと思っています。
    Aさんが3回を希望してたら、元から配置した分+ランダム配置=3
    になった時点でBさんに以降するようにしたいと考えてます。
    元から配置した分とランダムで配置された分があるので、わからなくなってしまいました。

    • オクタ゛シヨウヘイ より:

      コメントありがとうございます。
      設定リストのところで希望回数を入力して運用することになると思うのですが、このサンプルのコードだと夜勤については1日ずつに設定していくので、それだと希望回数に満たない人も出てきてしまいます。上限回数として認識させることは可能ですが。
      公休については1人ずつに決まった日数分ランダムで設定していくので、これを応用して夜勤を配置するのが良いかと思います。

  5. 通りすがり より:

    仕組みは分かるのですが、コードが面倒になることが分かってるので、作り上げたことについて素晴らしいと思わせられました。これからも頑張ってくださいー!!

  6. たまき より:

    質問なのですが今回も配置可能を1、不可能を0として扱っているのでしょうか?サンプル画像を拝見したところ早出が0になっている方も早出が入っているのでそういう仕様はないコードになっているのでしょうか?

  7. やまと より:

    こんにちは。質問してもよろしいでしょうか?
    作り直した方のコードだと1と0で配置の可不可を判定していないのでしょうか?初歩的な事ですいません。

    • やまと より:

      すいません。消えたと勘違いして同じようなコメントをしてしまっています。

      • しめひつ より:

        コメントありがとうございました。
        初回のコメント投稿は承認するまで一旦止まる仕様になっているので、勘違いされるのも無理ないです。気にしないでください。
        ご指摘いただいた点ですが、結論から申し上げると私の記述ミスでした。失礼いたしました。
        ファイルおよびこの記事のコードを修正し、掲載さいているキャプチャも差し替えしました。
        早出および遅出を自動入力するかは設定リストの0 or 1で切り替えていましたが、修正前のコードでは常勤列で判定していたため早出列が0だったとしても常勤列が1であれば早出も自動入力するという状態でした。
        コメントしていただいて大変助かりました。ありがとうございました。
        今後もお気付きの点がございましたらコメントを頂けますと幸いです。

コメントする前にお読みください

プログラミングに関する質問について、詳細なコードはお答えしませんのでご了承ください。
また、迷惑コメント防止のために初回のコメント投稿は承認制です。投稿が反映されるまで少し時間がかかります。