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

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

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

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

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

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

サンプル

https://www.iehohs.com/ftp/excel-auto-shift2.xlsm

というわけでサンプルです。

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

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

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

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

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

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

勤務配置

Sub autoMaking()
    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 randomPro(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
        
        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
                    
                    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 randomPro(rowArr())
                arrCnt = 0
                
                '空欄チェック
                Call colChkPro(rowStart, rowEnd, i, setCnt, colCfg)
            Else
                arrCnt = arrCnt + 1
            End If
        Loop
    Next
    
    '公休を配置
    Dim holCnt As Integer
    Call randomPro(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
            
            
            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 randomPro(colArr())
                    arrCnt = 0
                Else
                    arrCnt = arrCnt + 1
                End If
                
                '空欄チェック
                Call rowChkPro(colStart, colEnd, i, holCnt, colCfg)
            Loop
        End If
    Next
    
    '早出と遅出を配置
    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 randomPro(rowArr())
    arrCnt = 0
    
    For i = colStart To colEnd
        '早出は0、遅出は1
        For j = 0 To 1
            setCnt = hoCntArr(j)
            
            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
            
            Do While setCnt > 0
                If Cells(rowArr(arrCnt), colCfg).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 randomPro(rowArr())
                    arrCnt = 0
                Else
                    arrCnt = arrCnt + 1
                End If
                
                '空欄チェック
                Call colChkPro(rowStart, rowEnd, i, setCnt, colCfg)
            Loop
        Next
    Next
End Sub

Sub randomPro(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 colChkPro(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 rowChkPro(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()を用意しました。

新規シート作成

Sub reset()
    Dim colStart As Integer
    Dim colEnd As Integer
    Dim rowStart As Integer
    Dim rowEnd As Integer
    
    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
        MsgBox ("キャンセルが押されました。" _
            & vbCrLf & "作業を中止します。")
        Exit Sub
    End If
    
    If Not Len(thisYear) = 4 Then
        MsgBox ("西暦は4桁で入力してください。" _
            & vbCrLf & "作業を中止します。")
        Exit Sub
    End If
    
    Dim thisMonth As String
    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
    
    Dim thisSheetName As String
    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
    
    If thisMonth = 4 Or thisMonth = 6 Or thisMonth = 9 Or thisMonth = 11 Then
        colEnd = 32
    ElseIf thisMonth = 2 Then
        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
    Else
        colEnd = 33
    End If
    
    '1日の曜日を取得
    Dim fstWeekday As String
    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

この辺はほぼ同じです。

配置ボタン

Sub hayade()
    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 osode()
    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 yakin()
    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 kokyu()
    If Selection.Row >= 6 And Selection.Column >= 3 And Selection.Column <= 33 Then
        Selection.Value = "公休"
        Selection.Interior.ColorIndex = 0
    End If
End Sub

Sub nenkyu()
    If Selection.Row >= 6 And Selection.Column >= 3 And Selection.Column <= 33 Then
        Selection.Value = "年休"
        Selection.Interior.ColorIndex = 0
    End If
End Sub

Sub del()
    If Selection.Row >= 6 And Selection.Column >= 3 And Selection.Column <= 33 Then
        Selection.Value = ""
        Selection.Interior.Color = 16777215
    End If
End Sub

色の情報を設定リストから取得するようにしています。

制作の依頼はランサーズから

VBAについて知識のある方はまるっとコピペしていただいて、必要な箇所だけコードをいじって使ってください。

わからない点があればコメントいただければお答えはしますが、「ここをこうすればいいよ」ぐらいで具体的なコードはお伝えしませんのであしからず。

勤務体系とか必要な機能が増えたりとメンテナンスが必要なプログラムでしょうから、理解した上で使ってほしいという気持ちです。

もし、オリジナルな要件のプログラムをつくってほしいという方は、ランサーズからご依頼ください。1ボタン5,000円ぐらいで承ります。

奥田 祥平 | その他プログラマ・エンジニア | クラウドソーシング【ランサーズ】
奥田 祥平さんのプロフィールページです。日本最大級のクラウドソーシング「ランサーズ」は、実績とスキルのあるプロフェショナルに気軽に仕事を依頼できます。

ランサーズで出品しています

Excel VBAで勤務表シフト自動作成ツール | Excelマクロ作成・VBA開発 | ランサーズ
ボタンをクリックするだけでランダムに勤務を配置して勤務表(シフト)を作成します。あらかじめ希望休や勤務希望を入力しておき、予定が空いているところに決まった人数分の勤務を配置していきます。休日日数、各勤務配置の人数はもちろんのこと、「夜勤の翌日は休日」、「遅出の次の日は早出にしない」などといった条件も追加可能です。勤務表...

こんな感じで出品していますので、制作依頼がございましたら購入してください。

2万円(プラス手数料とか税金とか)で承ります!

コメント