シフト表作成マクロ【ソースコード】

Option Explicit
                                                
'設定シート
                                                '---名称---
Const SHT_NAME_STTNG As String = "設定"         '設定シート
Const SHT_NAME_TMPLT As String = "template"     'ひな形シート
Const MK_YEAR As String = "作成年"              '作成年セル
Const MK_MNTH As String = "作成月"              '作成月セル
                                                '---行---
Const STTNG_ROW_YEAR As Long = 6                '作成年
Const STTNG_ROW_MNTH As Long = 6                '作成月
Const STTNG_ROW_HLDY_ORGN As Long = 6           '休日開始行
Const STTNG_ROW_PRSN_ORGN As Long = 6           '担当開始行
                                                '---列---
Const STTNG_CLMN_YEAR As Long = 2               '作成年
Const STTNG_CLMN_MNTH As Long = 3               '作成月
Const STTNG_CLMN_HLDY As Long = 5               '休日
Const STTNG_CLMN_SHFT1 As Long = 7              'シフト１
Const STTNG_CLMN_SHFT2 As Long = 8              'シフト２

'シフト表シート
                                                '---行---
Const MTRX_ROW_ORGN As Long = 3                 'データ開始行
                                                '---列---
Const MTRX_CLMN_DATE As Long = 2                '日付
Const MTRX_CLMN_WEEK As Long = 3                '曜日
Const MTRX_CLMN_SHFT1 As Long = 4               'シフト１
Const MTRX_CLMN_SHFT2 As Long = 5               'シフト２
Const MTRX_CLMN_DUTY As Long = 6                '夜勤
Const MTRX_CLMN_DUTY_AFTR As Long = 7           '夜勤明け
Const MTRX_CLMN_HLDY As Long = 8                '休暇
Const MTRX_CLMN_CMMTT As Long = 9               '出張等

Const AUTO_SHFFL_RTRY_CNT = 500                 '自動シャッフルの最大試行回数


'
' シフト表作成ボタン押下処理
'
Sub onMkRspnsbltyMtrxBttn()

    Dim sht_sttng As Worksheet
    
    Application.ScreenUpdating = False
    
    Set sht_sttng = Worksheets(SHT_NAME_STTNG)
    
    '設定チェック
    If Not chkSttng Then
        Exit Sub
    End If

    '年月シート存在チェック
    If chkExstWrksht(getMtrxShtName(sht_sttng)) Then
        MsgBox Range(MK_YEAR) & "年" & Format(Range(MK_MNTH), "00") & "月のシートが既に存在します" _
        & vbCr & "シート名を変更または削除してください"
        Exit Sub
    End If

    'シフト表シート作成
    mkRspnsbltyMtrx
    
    '担当手動シャッフル
    onMnlShfflPrsnBttn

    '担当重複チェック
    chkDplctPrsn (False)

    Application.ScreenUpdating = True

End Sub

'
'自動シャッフルボタン押下処理
'
Sub onAutoShfflBttn()
    
    Dim i As Integer
    Dim cntErr As Integer
    
    Application.ScreenUpdating = False
    
    '設定チェック
    If Not chkSttng Then
        Exit Sub
    End If

    'シャッフル最大試行回数だけ
    For i = 0 To AUTO_SHFFL_RTRY_CNT
        
        '担当シャッフル
        shfflPrsn
    
        '担当重複チェック
        cntErr = chkDplctPrsn(True)
        If 0 = cntErr Then
            '重複がなければシャッフル終了
            Exit For
        End If

    Next i

    Application.ScreenUpdating = True
    
End Sub

'
'手動シャッフルボタン押下処理
'
Sub onMnlShfflPrsnBttn()
    
    Application.ScreenUpdating = False
    
    '設定チェック
    If Not chkSttng Then
        Exit Sub
    End If

    '担当シャッフル
    shfflPrsn

    '担当重複チェック
    chkDplctPrsn (False)

    Application.ScreenUpdating = True

End Sub

'
' 担当重複チェックボタン押下処理
'
Sub onChkDplctPrsnBttn()

    Application.ScreenUpdating = False
    
    Dim cntErr As Integer
    
    '設定チェック
    If Not chkSttng Then
        Exit Sub
    End If

    '担当重複チェック
    cntErr = chkDplctPrsn(False)
    If 0 = cntErr Then
        MsgBox "チェック OK"
    End If

    Application.ScreenUpdating = True

End Sub

'
' シフト表シート作成
'
Sub mkRspnsbltyMtrx()

    Dim sht_sttng As Worksheet
    Dim days As Integer
    Dim i As Integer
    
    Set sht_sttng = Worksheets(SHT_NAME_STTNG)

    '月の日数を取得
    days = Format(DateSerial(Range(MK_YEAR), Range(MK_MNTH) + 1, 0), "d")
    
    '作成年月のシートを作成
    Worksheets(SHT_NAME_TMPLT).Copy after:=sht_sttng
    ActiveSheet.Name = Range(MK_YEAR) & Format(Range(MK_MNTH), "00")
    ActiveSheet.Unprotect

    With ActiveSheet
    
        '日数調整
        If days < 31 Then
            .Rows((MTRX_ROW_ORGN + days) & ":" & (MTRX_ROW_ORGN + 31 - 1)).Delete
        End If
    
        '開始日セット
        .Cells(MTRX_ROW_ORGN, MTRX_CLMN_DATE) = _
            DateSerial(Range(MK_YEAR), Range(MK_MNTH), 1)
    
        '非稼働日を網掛け
        For i = MTRX_ROW_ORGN To MTRX_ROW_ORGN + days - 1
            
            '土日
            If isWeekEnd(.Cells(i, MTRX_CLMN_WEEK).Text) Then
                .Range(.Cells(i, MTRX_CLMN_DATE), _
                       .Cells(i, MTRX_CLMN_CMMTT)).Interior.ColorIndex = 15
            End If
            
            '祝日
            If isHldy(sht_sttng, .Cells(i, MTRX_CLMN_DATE)) Then
                .Range(.Cells(i, MTRX_CLMN_DATE), _
                       .Cells(i, MTRX_CLMN_CMMTT)).Interior.ColorIndex = 15
            End If
        Next i
    End With

End Sub

'
' 担当シャッフル(シフト１、シフト２)
'
Sub shfflPrsn()

    Dim sht_sttng As Worksheet
    Dim aryPrsn As Variant
    Dim days As Integer
    Dim i As Integer
    Dim prsn_idx As Integer
    
    Set sht_sttng = Worksheets(SHT_NAME_STTNG)

    '月の日数を取得
    days = Format(DateSerial(Range(MK_YEAR), Range(MK_MNTH) + 1, 0), "d")
    
    With ActiveSheet
    
        '担当の組み合わせを配列化
        aryPrsn = sht_sttng.Range( _
            sht_sttng.Cells(STTNG_ROW_PRSN_ORGN, STTNG_CLMN_SHFT1), _
            sht_sttng.Cells(sht_sttng.Cells(Rows.Count, STTNG_CLMN_SHFT2).End(xlUp).Row, _
                            STTNG_CLMN_SHFT2))
        '担当をシャッフル(初回)
        aryPrsn = shffl(aryPrsn)

        '担当セット
        prsn_idx = 1
        For i = MTRX_ROW_ORGN To MTRX_ROW_ORGN + days - 1
    
            If xlColorIndexNone = .Cells(i, MTRX_CLMN_DATE).Interior.ColorIndex Then
                .Cells(i, MTRX_CLMN_SHFT1) = sht_sttng.Cells(STTNG_CLMN_SHFT1, 1)
                
                'シフト１
                .Cells(i, MTRX_CLMN_SHFT1) = aryPrsn(prsn_idx, 1)
                .Cells(i, MTRX_CLMN_SHFT1).Interior.ColorIndex = xlNone
                'シフト２
                .Cells(i, MTRX_CLMN_SHFT2) = aryPrsn(prsn_idx, 2)
                .Cells(i, MTRX_CLMN_SHFT2).Interior.ColorIndex = xlNone
                
                'シフト１、シフト２のすべての担当をセットした場合
                prsn_idx = prsn_idx + 1
                If UBound(aryPrsn) < prsn_idx Then
                    '担当をシャッフル(2回目以降)
                    aryPrsn = shffl(aryPrsn)
                    prsn_idx = 1
                End If
            End If
            
        Next i
        
    End With

End Sub

'
' 設定チェック
'
Function chkSttng() As Boolean

    Dim sht_sttng As Worksheet
    Dim wkStr As String
    Dim ret As Boolean
    Dim rw As Long

    Set sht_sttng = Worksheets(SHT_NAME_STTNG)
    ret = True
    
    With sht_sttng
        Do
            '作成年[数値かつ4桁固定]
            wkStr = .Cells(STTNG_ROW_YEAR, STTNG_CLMN_YEAR)
            If Not wkStr Like "####" Then
                MsgBox "設定シートの年は、数字4桁で入力してください"
                ret = False
                Exit Do
            End If
            
            '作成月[数値かつ1～2桁]
            wkStr = .Cells(STTNG_ROW_MNTH, STTNG_CLMN_MNTH)
            If Not wkStr Like "#" And Not wkStr Like "##" Then
                MsgBox "設定シートの月は、数字1～2桁で入力してください"
                ret = False
                Exit Do
            End If
            
            '作成年・作成月[存在する年月]
            wkStr = .Cells(STTNG_ROW_YEAR, STTNG_CLMN_YEAR) & "/" & _
                    .Cells(STTNG_ROW_MNTH, STTNG_CLMN_MNTH) & "/" & "01"
            If Not IsDate(wkStr) Then
                MsgBox "設定シートの年月が、存在しない年月です"
                ret = False
                Exit Do
            End If

            '休日
            For rw = STTNG_ROW_HLDY_ORGN To .Cells(Rows.Count, STTNG_CLMN_HLDY).End(xlUp).Row
                '休日[歯抜け]
                If "" = .Cells(rw, STTNG_CLMN_HLDY) Then
                    MsgBox "設定シートの休日は、行を詰めて入力してください"
                    ret = False
                    Exit Do
                End If
                
                '休日[暦日]
                If Not IsDate(.Cells(rw, STTNG_CLMN_HLDY)) Then
                    MsgBox "設定シートの休日は、日付(YYYY/MM/DD)で入力してください"
                    ret = False
                    Exit For
                End If
            Next rw
            If Not ret Then
                Exit Do
            End If

        Loop While False
    End With

    chkSttng = ret

End Function

'
' ワークシート存在チェック
'
Function chkExstWrksht(sht_nm As String) As Boolean

    Dim ws As Worksheet
    Dim ret As Boolean
    
    ret = False
    For Each ws In Worksheets
        If sht_nm = ws.Name Then
            ret = True
            Exit For
        End If
    Next ws

    chkExstWrksht = ret

End Function

'
' シフト表のシート名を取得
'
Function getMtrxShtName(sht_sttng As Worksheet) As String

    getMtrxShtName = Range(MK_YEAR) & Format(Range(MK_MNTH), "00")

End Function

'
' 担当重複チェック
'
Function chkDplctPrsn(allwBlnkFlg As Boolean) As Integer

    Dim sht_mtrx As Worksheet
    Dim rslt As Range
    Dim i As Long
    Dim days As Integer
    Dim cntErr As Integer

    Set sht_mtrx = ActiveSheet
    cntErr = 0
    
    '月の日数を取得
    days = Format(DateSerial(Range(MK_YEAR), Range(MK_MNTH) + 1, 0), "d")

    With ActiveSheet
    
        For i = MTRX_ROW_ORGN To MTRX_ROW_ORGN + days - 1
    
            If xlColorIndexNone = .Cells(i, MTRX_CLMN_DATE).Interior.ColorIndex Then
                    
                .Range(Cells(i, MTRX_CLMN_SHFT1), Cells(i, MTRX_CLMN_CMMTT)).Interior.ColorIndex = xlNone
                
                '担当(シフト１)(の重複チェック
                If "" = .Cells(i, MTRX_CLMN_SHFT1) Then
                    .Cells(i, MTRX_CLMN_SHFT1).Interior.Color = vbRed
                    If Not allwBlnkFlg Then
                        cntErr = cntErr + 1
                    End If
                Else
                    Set rslt = .Range(.Cells(i, MTRX_CLMN_SHFT2), .Cells(i, MTRX_CLMN_CMMTT)) _
                                    .Find(what:=.Cells(i, MTRX_CLMN_SHFT1), lookat:=xlPart)
                    If Not (rslt Is Nothing) Then
                        .Cells(i, MTRX_CLMN_SHFT1).Interior.Color = vbRed
                        rslt.Interior.Color = vbRed
                        cntErr = cntErr + 1
                    End If
                End If
            
                '担当(シフト２)の重複チェック
                If "" = .Cells(i, MTRX_CLMN_SHFT2) Then
                    .Cells(i, MTRX_CLMN_SHFT2).Interior.Color = vbRed
                    If Not allwBlnkFlg Then
                        cntErr = cntErr + 1
                    End If
                Else
                    Set rslt = .Range(.Cells(i, MTRX_CLMN_DUTY), .Cells(i, MTRX_CLMN_CMMTT)) _
                                    .Find(what:=.Cells(i, MTRX_CLMN_SHFT2), lookat:=xlPart)
                    If Not (rslt Is Nothing) Then
                        .Cells(i, MTRX_CLMN_SHFT2).Interior.Color = vbRed
                        rslt.Interior.Color = vbRed
                        cntErr = cntErr + 1
                    End If
                End If
            
            End If

        Next i
        
    End With
        
    chkDplctPrsn = cntErr
    
End Function

'
' 土日判定
'
Function isWeekEnd(week As String) As Boolean

    Dim ret As Boolean

    ret = False

    If "土" = week Or "日" = week Then
        ret = True
    End If
    
    isWeekEnd = ret

End Function

'
' 祝日判定
'
Function isHldy(sht_sttng As Worksheet, dt As String) As Boolean

    Dim ret As Boolean
    Dim rw As Long

    ret = False

    For rw = STTNG_ROW_HLDY_ORGN To sht_sttng.Cells(Rows.Count, STTNG_CLMN_HLDY).End(xlUp).Row
        If sht_sttng.Cells(rw, STTNG_CLMN_HLDY) = dt Then
            ret = True
            Exit For
        End If
    Next rw

    isHldy = ret

End Function

'
'シャッフル(2次元文字配列)
'
Function shffl(ary As Variant) As Variant

    Dim tmp1 As String
    Dim tmp2 As String
    Dim i As Integer
    Dim r As Integer

    For i = 1 To UBound(ary)
        Randomize
        r = Int(UBound(ary) * Rnd) + 1
        tmp1 = ary(i, 1)
        tmp2 = ary(i, 2)
        ary(i, 1) = ary(r, 1)
        ary(i, 2) = ary(r, 2)
        ary(r, 1) = tmp1
        ary(r, 2) = tmp2
    Next i

    shffl = ary

End Function