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

24時間体制の部署ともなると勤務を組むのも一苦労で、1日仕事では済まないこともあるそうな。

そこでExcel VBAを使って条件通りにシフト表を自動作成するマクロを作成しました。

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

スポンサーリンク

プログラムの内容

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

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

シフト表を作成する上での要件をまとめます。

  • 早出、日勤、遅出、夜勤の4種類の配置がある
  • 1日あたり夜勤は2人、それ以外は1人ずつを最低限配置する
  • 夜勤は1.5労働とし、基本的に2日連続で入り翌日は「明け」、その翌日は公休とする
  • 夜勤を連続で入れない場合は翌日を年次有給休暇(年休)を半日使用する「半年」、その翌日を公休とする
  • 6日連続で勤務となった場合、公休を2日続けて取得する
  • 役職や個人の都合により特定の配置にしかつけない場合、「職員リスト」シートで「0」を入力する
  • 「職員リスト」では、1ヶ月あたりの夜勤の上限回数を指定する

操作について

上部に各種ボタンを配置しています。クリックするとマクロが動きます。

まず「新規」のボタンをクリックするとアクティブのシートを複製し、シフトをまっさらな状態にします。その際、年月を入力し、日数と曜日を取得します。

配置の書かれたボタンは、選択したセルにそれぞれの配置を入力することができます。希望休など予定が決まってるのでればあらかじめ入力しておきます。

実行ボタンを押すと、空いているセルに次々と配置を入れていきます。職員はランダムに選出され、既に予定が入っているところは避けます。また、既に定員分の入力がされている配置についてはスキップします。

これで決まっている予定を守りつつ最低限の配置がされます。あとは公休の日数を調整しながら、手動で配置をしていく感じです。

シフト作成作業の6割程度が自動化されるイメージです。公休の日数調整までやろうとすればできるのですが、勤務のバランスをとるのが難しいので、仕上げは人がやると割り切った方が効率的だという判断です。

プログラミング

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          '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で配列をシャッフルする(要素をランダムに並べ替える)を参考にしました。

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       '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

特に言うことはありません。閏年の判定については前に記事にしましたので説明は不要です。

強いて言うなら曜日は初日の分を取得し、あとはオートフィルで仕上げていること。それだけ。

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/選択している行をハイライト表示する方法を参考にしています。

コメント

  1. 佐々木真司 より:

    実用性のある素晴らしいVBA情報ありがとうございます。質問になりますが夜勤は1.5労働とし、基本的に2日連続で入り翌日は「明け」、その翌日は公休とするの条件に遅番を追加する場合はどうすればよろしいでしょうか?

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

      佐々木真司 様
      コメントありがとうございます。
      autoMakingプロシージャの205行目にある”公休”を”遅出”に変えればできます。
      公休か遅出のどちらかをランダムで配置という場合は、さらにひと手間が必要ですのでここでの説明は割愛します。

  2. 山田義久 より:

    素晴らしいVBAですね。
    初心者にはとてもありがたいです。
    遅出の次の日は早出にしないということはできますでしょうか。

  3. 山田義久 より:

    素晴らしい機能でした。
    VBA初学者なので、ほとんど書いてあることが分からないのですが、少しずつコマンドを勉強しています。
    遅出の次の日は、早出以外(日勤か遅出のランダム)としたいのですが、どうしたらよいでしょうか

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

      山田義久 様
      コメントありがとうございます。
      遅出の次の日は早出以外とするのは可能です。
      97行目からのForループが各配置の処理になるのですが、早出の処理はiが1の時に行われます。
      149行目あたりに、iが1の場合、1列前のセルの値を確認し「遅出」だった場合はsetFlgをFalseにするという分岐を加えたらできます。
      あまり難しくない処理なので、調べながらコードを書いてみてください。
      ヒントとしましては、処理を行う行番号はsetRow、列番号はsetColで表すので、1列前のセルを参照する場合はsetCol – 1で表せます。

  4. 近江鈴雅 より:

    実用的な素晴らしい情報ありがとうございます。
    質問ですが必ず3連勤「同じ時間を」入れたい場合はどうすればよろしいでしょうか?

    • しめひつ より:

      コメントありがとうございます。
      151行目と152行目がセルに入力するコードですので、翌日と翌々日の分も同時に入力するようにすればよいかと思います。

    • 斉藤かおり より:

      病院勤務表用のVBAを探していて、やっとで辿り着きました。細かい設定までしてあり、とても助かります。
      質問なのですが、「早番」「遅番」をなくす事は可能でしょうか?

      • しめひつ より:

        コメントありがとうございます。
        VBA上で編集するのであれば、夜勤→公休→早出→遅出の順番で処理しているので、夜勤と公休だけ残して他を削除することでそのような仕様に変えることは可能です。

        https://www.iehohs.com/excel-auto-shift4/
        最新版の方であれば、早出と遅出の設定人数を0にすれば夜勤と公休のみの仕様に変えられます。

  5. 川口峻佑 より:

    大変実用的な資料をありがとうございます。とても助かります。
    各作業員の1月あたりの出勤日数を制限するにはどういったプログラムを書き込めばよいでしょうか?全員統一ではなく個人個人で上限日数を設けたいです。
    よろしくお願いします。

    • しめひつ より:

      シート上で各職員個人ごとの上限日数を入力するセルを作って、抽選時に出勤日数を数えて上限に達していないかを判定させればよいのではないでしょうか。

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

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