Excelでシフトを自動作成するマクロを作成しました。

生業の方でできないかという提案があり、作ったものをサンプル化しました。

これまで自分がやってきたことの集大成的なマクロになりました。実用性があるかと言われれば断言できませんが、応用すればそれなりのものにはなるんじゃないですかね。

サンプルデータ

excel-auto-shift.xlsm

こちらがサンプルファイルです。悪意のあるソースは含まれておりませんのでご安心を。

スクリーンショットにあるようなシフト表を作成します。要件としましては、

• 早出、日勤、遅出、夜勤の４種類の配置がある
• １日あたり夜勤は２人、それ以外は１人ずつを最低限配置する
• 夜勤は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/選択している行をハイライト表示する方法を参考にしています。

そんな感じです。以上。