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

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          '６連勤カウント
    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

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       '１日の曜日
    '年月入力
    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

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

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Application.ScreenUpdating = True
End Sub
'条件付き書式に
'=OR(CELL("ROW")=ROW(), CELL("COL")=COLUMN())
'の条件で背景色を設定