LoginSignup
1
2

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

More than 3 years have passed since last update.

@MatchaLatte

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

Last updated at Posted at 2022-04-18

このマクロでできること

定義されたタスクのスケジュールを自動的に組みます。
なおマクロを実行する前に事前にタスクの洗い出しと、そのタスクにかかる時間を見積もる必要があります。
image.png

各エクセルシートの作成

[SCHEDULE]シート

[SCHEDULE]というシート名で、下記のようなフォーマットを作成します。
黄色いところで塗りつぶしている列は手動で埋めます。
青い列は自動で入力される部分となります。
また[D3]セルには作業開始日を入力します。
ボタンは[スケジュール作成]と[カレンダー追加]を2つ任意の場所に作成。
各ボタンにはスケジュール作成とカレンダー追加のプロージャーを割り当てます。

B列 C列 D列 E列 F列 G列 H列
番号 タスク(大分類) タスク(中分類) タスク(小分類) 担当者 時間 進捗（[未着手][対応中][完了]のいずれか）

image.png

[WORKER]シート

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

image.png

[HOLIDAY]シート

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

image.png

マクロ

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

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

シートのカスタマイズ

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

おわりに

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

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

1
2
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
1
2

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?