【VBA】エクセルでスケジュールを自動作成

# このマクロでできること
定義されたタスクのスケジュールを自動的に組みます。
なおマクロを実行する前に事前にタスクの洗い出しと、そのタスクにかかる時間を見積もる必要があります。
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/650417/dc731624-146b-b428-e577-21ccb7cbac6e.png)

# 各エクセルシートの作成
### [SCHEDULE]シート
[SCHEDULE]というシート名で、下記のようなフォーマットを作成します。
黄色いところで塗りつぶしている列は手動で埋めます。
青い列は自動で入力される部分となります。
また[D3]セルには作業開始日を入力します。
ボタンは[スケジュール作成]と[カレンダー追加]を2つ任意の場所に作成。
各ボタンにはスケジュール作成とカレンダー追加のプロージャーを割り当てます。
|B列  |C列  |D列  |E列  |F列  |G列  |H列  |
|---|---|---|---|---|---|---|
|番号|タスク(大分類)|タスク(中分類)|タスク(小分類)|担当者|時間|進捗（[未着手][対応中][完了]のいずれか）|

![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/650417/b6a9d034-ef98-8f65-bd7d-3c668b0625c3.png)

### [WORKER]シート
[WORKER]というシート名で、下記のようなシートを作成します。
作業者の名前とその人が一日あたりの作業時間を記入します。
ここで定義した時間がその人の一日あたりの生産量となります。

![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/650417/09299ece-5c4e-e220-6a3d-866b73c8d0ad.png)

### [HOLIDAY]シート
[HOLIDAY]というシート名で、下記のようなシートを作成します。
定休日（曜日）、祝日、各作業者の休暇予定日をこのシートに定義します。
ここで定義された休みの日には、作業は割り振らなくなります。

![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/650417/568d295d-4b60-53b3-34ad-a9a09c462bdc.png)

# マクロ
コードです。
標準モジュールに下記コードを記述します。
コードの詳しい解説は省略します。

```vb:Module1
Const SCHEDULE_SHEET_MONTH_ROW                  As Integer = 5
Const SCHEDULE_SHEET_CALENDAR_ROW               As Integer = 6
Const SCHEDULE_SHEET_TASK_START_ROW             As Integer = 7
Const SCHEDULE_SHEET_WORKER_COL                 As Integer = 6
Const SCHEDULE_SHEET_TIME_COL                   As Integer = 7
Const SCHEDULE_SHEET_PROGRESS                   As Integer = 8
Const SCHEDULE_SHEET_START_DAY_COL              As Integer = 9
Const SCHEDULE_SHEET_END_DAY_COL                As Integer = 10
Const SCHEDULE_SHEET_CALENDAR_START_COL         As Integer = 11
Const SCHEDULE_SHEET_MONTHE_FORMAT              As String = "m月"
Const SCHEDULE_SHEET_CALENDAR_FORMAT            As String = "m/d(aaa)"

Const WORKER_SHEET_WORKER_COL                   As Integer = 3
Const WORKER_SHEET_WORKER_START_ROW             As Integer = 3
Const WORKER_SHEET_WORKER_COL_RNG               As String = "C:C"

Const HOLIDAY_SHEET_WORKER_HOLIDAY_START_ROW    As Integer = 3
Const HOLIDAY_SHEET_WORKER_COL                  As Integer = 8
Const HOLIDAY_SHEET_WORKER_HOLIDAY_COL          As Integer = 9
Const HOLIDAY_SHEET_REGULAR_HOLIDAY_COL_RNG     As String = "B:B"
Const HOLIDAY_SHEET_NATIONAL_DAY_COL_RNG        As String = "F:F"
Const HOLIDAY_SHEET_WORKER_HOLIDAY_COL_RNG      As String = "I:I"

Const SCHEDULE_SHEETNAME                        As String = "SCHEDULE"
Const HOLIDAY_SHEETNAME                         As String = "HOLIDAY"
Const WORKER_SHEETNAME                          As String = "WORKER"

'メインのプロージャー
Sub CreateSchedule()
    Application.StatusBar = "処理を開始します。"
    '描画を停止する
    Application.ScreenUpdating = False

'エラーが起きたときはErrorHandler:へ飛ぶ
On Error GoTo ErrorHandler

    '入力チェック
    Dim emptyRow As Integer
    
    '担当者の入力チェック
    Application.StatusBar = "入力チェックを処理中"
    emptyRow = WorkerIsEmpty
    If Not (emptyRow = 0) Then
        MsgBox emptyRow & "行目の担当者が入力されていません。" & vbLf & "担当者を入力して再度実行してください。", vbOKOnly + vbExclamation, "入力誤り"
        GoTo Finally
    End If
    
    '作業時間の入力チェック
    emptyRow = TimeIsEmpty
    If Not (emptyRow = 0) Then
        MsgBox emptyRow & "行目の時間(h)が入力されていません。" & vbLf & "時間を入力して再度実行してください。", vbOKOnly + vbExclamation, "入力誤り"
        GoTo Finally
    End If
    
    Application.StatusBar = "エクセルへ出力処理中"
    
    '作業開始日の列を取得
    Dim Target As Range
    Dim tmpLoopDay As Integer
    Set Target = Worksheets(SCHEDULE_SHEETNAME).Range(Cells(SCHEDULE_SHEET_CALENDAR_ROW, SCHEDULE_SHEET_CALENDAR_START_COL), Cells(SCHEDULE_SHEET_CALENDAR_ROW, getCalenderEndCol)).Find(What:=Worksheets(SCHEDULE_SHEETNAME).Range("D3"))
    
    '作業開始日の列が見つからない場合はカレンダー開始日をスタート地点とする
    If Not (Target Is Nothing) Then
        tmpLoopDay = Target.Column
    Else
        tmpLoopDay = SCHEDULE_SHEET_CALENDAR_START_COL
    End If
    
    '日付毎にループを回し、時間を出力
    Dim loopDay As Integer
    For loopDay = tmpLoopDay To getCalenderEndCol
        '休日の場合はスキップする
        If isHoliday(loopDay) Then
            GoTo Continue
        End If
        Call AllocationWorkerDayTask(loopDay)
Continue:
    Next
    
    '開始日と終了日を出力する
    Call outputStartDayAndEndDya
    If IsTaskEndPlan Then
        MsgBox "カレンダーが足りませんでした。"
    Else
        MsgBox "処理が完了しました", vbOKOnly + vbInformation, "完了"
    End If
    GoTo Finally

'例外処理
ErrorHandler:
    'エラーメッセージを表示する
    MsgBox "エラーが発生しました。", vbCritical & vbOKOnly, "エラー"

    'Finally:へ飛ぶ
    Resume Finally

'後処理
Finally:
    Application.ScreenUpdating = True
    Application.StatusBar = ""
    
End Sub

Function IsTaskEndPlan() As Boolean
    'タスク毎にループを回す
    Dim loopTaskRow As Integer
    For loopTaskRow = SCHEDULE_SHEET_TASK_START_ROW To getTaskEndRow
        If Worksheets(SCHEDULE_SHEETNAME).Cells(loopTaskRow, SCHEDULE_SHEET_END_DAY_COL).Value = "" And (Not (Worksheets(SCHEDULE_SHEETNAME).Cells(loopTaskRow, SCHEDULE_SHEET_PROGRESS).Value = "完了")) Then
            IsTaskEndPlan = True
            Exit For
        End If
    Next
End Function

'担当者の入力チェック
Function WorkerIsEmpty() As Integer

    WorkerIsEmpty = 0
    
    'タスク毎にループを回す
    Dim loopTaskRow As Integer
    For loopTaskRow = SCHEDULE_SHEET_TASK_START_ROW To getTaskEndRow
        If Worksheets(SCHEDULE_SHEETNAME).Cells(loopTaskRow, SCHEDULE_SHEET_WORKER_COL).Value = "" Then
            WorkerIsEmpty = loopTaskRow
        End If
    Next
    
End Function


'作業にかかる時間の入力チェック
Function TimeIsEmpty() As Integer

    TimeIsEmpty = 0
    
    'タスク毎にループを回す
    Dim loopTaskRow As Integer
    For loopTaskRow = SCHEDULE_SHEET_TASK_START_ROW To getTaskEndRow
        If Worksheets(SCHEDULE_SHEETNAME).Cells(loopTaskRow, SCHEDULE_SHEET_TIME_COL).Value = "" Then
            TimeIsEmpty = loopTaskRow
        End If
    Next
    
End Function


'開始日と終了日を出力する
Sub outputStartDayAndEndDya()

    'タスク毎にループを回す
    Dim loopTaskRow As Integer
    
    For loopTaskRow = SCHEDULE_SHEET_TASK_START_ROW To getTaskEndRow
        With Worksheets(SCHEDULE_SHEETNAME)
            .Cells(loopTaskRow, SCHEDULE_SHEET_START_DAY_COL) = .Cells(SCHEDULE_SHEET_CALENDAR_ROW, .Cells(loopTaskRow, SCHEDULE_SHEET_END_DAY_COL).End(xlToRight).Column)
            .Cells(loopTaskRow, SCHEDULE_SHEET_END_DAY_COL) = .Cells(SCHEDULE_SHEET_CALENDAR_ROW, .Cells(loopTaskRow, getCalenderEndCol).End(xlToLeft).Column)
        End With
    Next
    
End Sub


'定休日または祝日の場合はTRUEを返す
Function isHoliday(dayCol As Integer) As Boolean

    isHoliday = False
    
    If isRegularHoliday(dayCol) Or isNationalHoliday(dayCol) Then
        isHoliday = True
        Exit Function
    End If
    
End Function


'祝日の場合はTRUEを返す
Function isNationalHoliday(dayCol As Integer) As Boolean

    With Worksheets(HOLIDAY_SHEETNAME)
        Dim Target As Range
        Set Target = .Range(HOLIDAY_SHEET_NATIONAL_DAY_COL_RNG).Find(What:=Worksheets(SCHEDULE_SHEETNAME).Cells(SCHEDULE_SHEET_CALENDAR_ROW, dayCol))
        If Target Is Nothing Then
            isNationalHoliday = False
        Else
            isNationalHoliday = True
        End If
    End With
    
End Function


'定休日の場合はTRUEを返す
Function isRegularHoliday(dayCol As Integer) As Boolean

    Dim dayOfWeek As String
    
    With Worksheets(SCHEDULE_SHEETNAME)
        dayOfWeek = NumToDayOfWeek(Weekday(.Cells(SCHEDULE_SHEET_CALENDAR_ROW, dayCol)))
    End With
     
    With Worksheets(HOLIDAY_SHEETNAME)
        Dim Target As Range
        Set Target = .Range(HOLIDAY_SHEET_REGULAR_HOLIDAY_COL_RNG).Find(What:=dayOfWeek)
        If Target.Offset(0, 1) = "定休日" Then
            isRegularHoliday = True
        Else
            isRegularHoliday = False
        End If
    End With
    
End Function


'1～7の数字を曜日に変換
Function NumToDayOfWeek(num As Integer) As String

    Select Case num
        Case 1
            NumToDayOfWeek = "日"
        Case 2
            NumToDayOfWeek = "月"
        Case 3
            NumToDayOfWeek = "火"
        Case 4
            NumToDayOfWeek = "水"
        Case 5
            NumToDayOfWeek = "木"
        Case 6
            NumToDayOfWeek = "金"
        Case 7
            NumToDayOfWeek = "土"
    End Select
    
End Function


'一日の仕事を割り振る
Sub AllocationWorkerDayTask(dayCol As Integer)

    '担当者毎にループを回す
    Dim loopWorker As Integer
    For loopWorker = WORKER_SHEET_WORKER_START_ROW To getWorkerEndRow
        Dim workerName As String
        workerName = Worksheets(WORKER_SHEETNAME).Cells(loopWorker, WORKER_SHEET_WORKER_COL).Value
        
        '担当者が休暇取得日の場合はスキップ
        If isWorkerHoliday(dayCol, workerName) Then
            GoTo Continue
        End If
        
        Call AllocationWorker(workerName, dayCol)
Continue:
    Next
    
End Sub


'担当者が休暇取得日の場合はTRUEを返す
Function isWorkerHoliday(dayCol As Integer, workerName As String) As Boolean

    isWorkerHoliday = False
     
    With Worksheets(HOLIDAY_SHEETNAME)
        Dim loopWorkerHoliday As Integer
        For loopWorkerHoliday = HOLIDAY_SHEET_WORKER_HOLIDAY_START_ROW To getWorkerHolidayEndRow
            If .Cells(loopWorkerHoliday, HOLIDAY_SHEET_WORKER_COL) = workerName And .Cells(loopWorkerHoliday, HOLIDAY_SHEET_WORKER_HOLIDAY_COL) = Worksheets(SCHEDULE_SHEETNAME).Cells(SCHEDULE_SHEET_CALENDAR_ROW, dayCol) Then
                isWorkerHoliday = True
                Exit For
            End If
        Next
    End With
    
End Function

'担当者にタスクを割り振る
Sub AllocationWorker(workerName As String, dayCol As Integer)

    'タスク毎にループを回す
    Dim loopTaskRow As Integer
   
    '一日あたりに可能な残り作業時間
    Dim workerTimeLeft As Double
    workerTimeLeft = getDayWorkTime(workerName)
    For loopTaskRow = SCHEDULE_SHEET_TASK_START_ROW To getTaskEndRow
        With Worksheets(SCHEDULE_SHEETNAME)
                
            '既に完了済みのものはスキップ
            If .Cells(loopTaskRow, SCHEDULE_SHEET_PROGRESS) = "完了" Then
                GoTo Continue
            End If
            
            '自身の担当作業でなければスキップ
            If Not (.Cells(loopTaskRow, SCHEDULE_SHEET_WORKER_COL).Value = workerName) Then
                GoTo Continue
            End If
            
            '現在計画されているタスクの合計時間を取得
            Dim planTaskTime As Double
            planTaskTime = getPlanTaskTime(loopTaskRow)
            
            '既に計画された作業の場合はスキップ
            If planTaskTime >= getTaskTime(loopTaskRow) Then
                GoTo Continue
            End If
            
            'タスクにかかる残り時間を取得
            Dim taskRemainingTime As Double
            taskRemainingTime = getTaskTime(loopTaskRow) - planTaskTime
            
            '時間を出力
            If workerTimeLeft < taskRemainingTime Then
                .Cells(loopTaskRow, dayCol).Value = workerTimeLeft
                workerTimeLeft = 0
            Else
                .Cells(loopTaskRow, dayCol).Value = taskRemainingTime
                workerTimeLeft = workerTimeLeft - taskRemainingTime
            End If
        End With
        
        If workerTimeLeft = 0 Then
            Exit For
        End If
Continue:
    Next
    
End Sub


'特定の作業の計画されている合計時間を取得
Function getPlanTaskTime(row As Integer) As Double

    getPlanTaskTime = WorksheetFunction.Sum(Worksheets(SCHEDULE_SHEETNAME).Range(Cells(row, SCHEDULE_SHEET_CALENDAR_START_COL), Cells(row, getCalenderEndCol)))
    
End Function


'作業時間を取得
Function getTaskTime(row As Integer) As Double

    getTaskTime = Worksheets(SCHEDULE_SHEETNAME).Cells(row, SCHEDULE_SHEET_TIME_COL).Value
    
End Function


'タスクの最終行を返す
Function getTaskEndRow() As Integer

    getTaskEndRow = Worksheets(SCHEDULE_SHEETNAME).Cells(Rows.Count, SCHEDULE_SHEET_WORKER_COL).End(xlUp).row
    
End Function


'担当者の休暇予定の最終行を取得
Function getWorkerHolidayEndRow() As Integer

    getWorkerHolidayEndRow = Worksheets(HOLIDAY_SHEETNAME).Cells(Rows.Count, HOLIDAY_SHEET_WORKER_HOLIDAY_COL).End(xlUp).row
    
End Function


'作業者の最終行を返す
Function getWorkerEndRow() As Integer

    getWorkerEndRow = Worksheets(WORKER_SHEETNAME).Cells(Rows.Count, WORKER_SHEET_WORKER_COL).End(xlUp).row
    
End Function


'カレンダーの最終列を返す
Function getCalenderEndCol() As Integer

    getCalenderEndCol = Worksheets(SCHEDULE_SHEETNAME).Cells(SCHEDULE_SHEET_CALENDAR_ROW, Columns.Count).End(xlToLeft).Column
    
End Function


'作業者の一日あたりに作業可能な時間を返す
Function getDayWorkTime(worker As String) As Double

    Dim Target As Range
    Set Target = Worksheets(WORKER_SHEETNAME).Range(WORKER_SHEET_WORKER_COL_RNG).Find(What:=worker)
    getDayWorkTime = Target.Offset(0, 1)
    
End Function


'翌月のカレンダーを作成する
Sub createCalendar()
    Dim createMonthe As Variant
    createMonthe = Application.InputBox(prompt:="何か月分のカレンダーを作成しますか。", _
                                Title:="数値入力", _
                                Type:=1)
    If TypeName(createMonthe) = "Boolean" Then
        MsgBox "キャンセルします"
        End
    End If
    
    Application.ScreenUpdating = False
    
    Dim loopMonth As Integer
    For loopMonth = 0 To CInt(createMonthe) - 1
    
        With Worksheets(SCHEDULE_SHEETNAME)
            Dim calendarDay  As Date
            Dim montheEndDay As Date
            Dim outputCol    As Integer
            Dim startCol     As Integer
            Dim endCol       As Integer
    
            outputCol = getCalenderEndCol + 1
            startCol = outputCol
            calendarDay = DateAdd("d", 1, .Cells(SCHEDULE_SHEET_CALENDAR_ROW, getCalenderEndCol))
            montheEndDay = DateSerial(Year(.Cells(SCHEDULE_SHEET_CALENDAR_ROW, getCalenderEndCol) + 1), Month(.Cells(SCHEDULE_SHEET_CALENDAR_ROW, getCalenderEndCol) + 1) + 1, 0)
            
            '月の入力
            .Cells(SCHEDULE_SHEET_MONTH_ROW, getCalenderEndCol + 1) = calendarDay
    
            '一か月分の日付の入力
            While calendarDay <= montheEndDay
                .Cells(SCHEDULE_SHEET_CALENDAR_ROW, outputCol) = calendarDay
                calendarDay = DateAdd("d", 1, calendarDay)
                endCol = outputCol
                outputCol = outputCol + 1
            Wend
            
            .Cells(SCHEDULE_SHEET_MONTH_ROW, startCol).NumberFormatLocal = SCHEDULE_SHEET_MONTHE_FORMAT
            .Range(Cells(SCHEDULE_SHEET_CALENDAR_ROW, startCol), Cells(SCHEDULE_SHEET_CALENDAR_ROW, endCol)).NumberFormatLocal = SCHEDULE_SHEET_CALENDAR_FORMAT
            
            'セルの結合
            .Range(Cells(SCHEDULE_SHEET_MONTH_ROW, startCol), Cells(SCHEDULE_SHEET_MONTH_ROW, endCol)).Merge
            
            'フォント、セル色、中央ぞろえ
            With .Range(Cells(SCHEDULE_SHEET_MONTH_ROW, startCol), Cells(SCHEDULE_SHEET_CALENDAR_ROW, endCol))
                .Font.Size = 8
                .Font.Name = "Meiryo UI"
                .Interior.Color = RGB(0, 176, 240)
                .HorizontalAlignment = xlCenter
            End With
            
            '罫線
            .Range(Cells(SCHEDULE_SHEET_MONTH_ROW, startCol), Cells(getTaskEndRow, endCol)).CurrentRegion.Borders.LineStyle = xlContinuous
            
        End With
    
    Next
    Application.ScreenUpdating = True
    MsgBox "カレンダーを追加しました。", vbOKOnly + vbInformation, "完了"
    
End Sub


```

# シートのカスタマイズ

シートのカスタマイズで、行や列を変える際はコードで定義している定数を修正する必要があるので注意が必要です。

# おわりに
初投稿でした。
かなり見苦しいコードになってしまったと猛省しております・・・

今回このマクロを作った意図として、リスケの度にスケジュールを書き換えるのがめんどくさいというのがありました。
まぁ、リスケが何度も必要になってしまうスケジュールは良くないですよね・・・