エクセルで工程表を自動作成する方法と、8年でわかった限界

Option Explicit

'==== 設定（自分の表に合わせて、ここだけ変える） ====
Private Const SHEET_NAME    As String = "全体工程"   ' ガントチャートを描くシート
Private Const LIST_SHEET    As String = "作業リスト" ' 作業リストのテーブルがあるシート
Private Const TABLE_NAME    As String = "作業リスト" ' テーブルの名前
Private Const START_CELL    As String = "B2"  ' 表の左端にしたい日付（ドロップダウン）
Private Const MONTH_ROW     As Long = 2       ' 月のラベルを出す行
Private Const HEAD_ROW      As Long = 3       ' 日付を並べる行
Private Const WEEK_ROW      As Long = 4       ' 曜日の行（=E3 の数式が入っている）
Private Const FIRST_ROW     As Long = 5       ' 1件目のタイトル行
Private Const FIRST_COL     As Long = 5       ' E列からカレンダーを描く
Private Const DAY_COUNT     As Long = 60      ' 横に何日ぶん出すか
Private Const ROWS_PER_JOB  As Long = 3       ' タイトル行＋バー行＋隙間行
Private Const H_TITLE       As Double = 17    ' タイトル行の高さ
Private Const H_BAR         As Double = 13    ' バーの行の高さ（細いほど締まって見える）
Private Const H_GAP         As Double = 5     ' すきまの行の高さ

'---- ここから下は「その日の詳細工程」用 ----
Private Const DAILY_SHEET   As String = "詳細工程" ' 時間単位で描くシート
Private Const DAILY_CELL    As String = "B2"  ' 表示する日付（ドロップダウン）
Private Const HOUR_COUNT    As Long = 24      ' 0時から24時まで並べる
Private Const WORK_START    As Long = 8       ' 日勤の始まり
Private Const WORK_END      As Long = 17      ' 日勤の終わり
Private Const LUNCH_HOUR    As Long = 12      ' 昼休み

Public Sub DrawGantt()
    Dim ws As Worksheet
    Dim lo As ListObject
    Dim baseDate As Date
    Dim i As Long, n As Long
    Dim d As Date
    Dim lastRow As Long
    Dim titleRow As Long, barRow As Long
    Dim sDate As Date, eDate As Date
    Dim sCol As Long, eCol As Long
    Dim memoCol As Long, k As Long
    Dim memo As String

    Set ws = ThisWorkbook.Worksheets(SHEET_NAME)
    Set lo = ThisWorkbook.Worksheets(LIST_SHEET).ListObjects(TABLE_NAME)
    baseDate = ws.Range(START_CELL).Value
    lastRow = FIRST_ROW + lo.ListRows.Count * ROWS_PER_JOB - 1

    ' 備考の列があるかどうかを先に調べておく。無いブックでもエラーにしないため
    memoCol = ColIndex(lo, "備考")

    Application.ScreenUpdating = False

    ' 1) 前回描いた内容を全部消す
    ClearArea ws, DAY_COUNT

    ' 2) 見出しを引き直す（2行目=月・3行目=日。4行目の曜日は数式が追従する）
    ' 月のラベルは必ず「文字」として入れる。日本語のExcelは "2026年9月" を
    ' 日付だと解釈してしまい、列幅が狭いと ### になるため先に表示形式を文字列にする
    ws.Range(ws.Cells(MONTH_ROW, FIRST_COL), _
             ws.Cells(MONTH_ROW, FIRST_COL + DAY_COUNT - 1)).NumberFormat = "@"

    For i = 0 To DAY_COUNT - 1
        d = baseDate + i
        ws.Cells(HEAD_ROW, FIRST_COL + i).Value = d
        ' 月のラベルは左端と月初だけ。隣は空のままにしないと文字がはみ出せない
        If i = 0 Or Day(d) = 1 Then
            ws.Cells(MONTH_ROW, FIRST_COL + i).Value = Format$(d, "yyyy年m月")
        End If
    Next i

    ' 3) 先に土日を塗る（ここから下は塗る順番がそのまま重なる順番になる）
    '    2行目（月のラベル）は塗らない。月名は右隣の空セルへはみ出して表示するので、
    '    途中に色が入ると文字の下だけ帯が入ったように見える
    For i = 0 To DAY_COUNT - 1
        d = baseDate + i
        If Weekday(d, vbMonday) >= 6 Then
            ws.Range(ws.Cells(WEEK_ROW, FIRST_COL + i), _
                     ws.Cells(lastRow, FIRST_COL + i)).Interior.Color = RGB(231, 226, 216)
        End If
    Next i

    ' 4) その上にバーを重ねる
    For n = 1 To lo.ListRows.Count
        titleRow = FIRST_ROW + (n - 1) * ROWS_PER_JOB
        barRow = titleRow + 1

        ' 行の高さもここで揃える。揃えないと3行とも同じ高さのままで、
        ' せっかく3行1セットにしてもバーが太く見えて締まらない
        ws.Rows(titleRow).RowHeight = H_TITLE
        ws.Rows(barRow).RowHeight = H_BAR
        ws.Rows(barRow + 1).RowHeight = H_GAP

        ws.Cells(titleRow, 2).Value = _
            lo.ListColumns("作業内容").DataBodyRange.Cells(n).Value

        sDate = lo.ListColumns("開始日").DataBodyRange.Cells(n).Value
        eDate = lo.ListColumns("終了日").DataBodyRange.Cells(n).Value

        ' 表示している期間から外れている作業は描かない
        If eDate >= baseDate And sDate <= baseDate + DAY_COUNT - 1 Then

            If sDate < baseDate Then sDate = baseDate
            If eDate > baseDate + DAY_COUNT - 1 Then eDate = baseDate + DAY_COUNT - 1

            sCol = FIRST_COL + DateDiff("d", baseDate, sDate)
            eCol = FIRST_COL + DateDiff("d", baseDate, eDate)

            ws.Range(ws.Cells(barRow, sCol), ws.Cells(barRow, eCol)) _
              .Interior.Color = RGB(15, 118, 110)

            ' 備考はバーの真上（タイトル行）に置く。タイトル行のカレンダー側は
            ' 空いているので、右隣の空セルへはみ出してそのまま読める
            If memoCol > 0 Then
                memo = CStr(lo.ListColumns(memoCol).DataBodyRange.Cells(n).Value)
                If Len(memo) > 0 Then
                    With ws.Cells(titleRow, sCol)
                        .Value = memo
                        .HorizontalAlignment = xlLeft
                    End With
                End If
            End If
        End If
    Next n

    ' 5) 最後に罫線を引き直す
    DrawBorders ws, lo.ListRows.Count, baseDate

    Application.ScreenUpdating = True
End Sub

'==== 前回描いた内容を消す（全体工程・詳細工程で共通）====
Private Sub ClearArea(ws As Worksheet, colCount As Long)
    Dim lastRow As Long, lastCol As Long

    ' 消す範囲は「そのシートで何かが入っている最終行」まで。作業名の位置から
    ' 逆算すると、名前を手で消したときに範囲が縮んで、前のバーが残ってしまう
    lastRow = ws.UsedRange.Row + ws.UsedRange.Rows.Count - 1
    If lastRow < FIRST_ROW Then lastRow = FIRST_ROW
    lastCol = FIRST_COL + colCount - 1

    ' 2行目のラベルは値も色も消す
    With ws.Range(ws.Cells(MONTH_ROW, FIRST_COL), ws.Cells(MONTH_ROW, lastCol))
        .ClearContents
        .Interior.ColorIndex = xlNone
    End With

    ' 3行目は「値だけ」消す（見出しの背景色は残したいため）
    ws.Range(ws.Cells(HEAD_ROW, FIRST_COL), ws.Cells(HEAD_ROW, lastCol)).ClearContents

    ws.Range(ws.Cells(WEEK_ROW, FIRST_COL), _
             ws.Cells(WEEK_ROW, lastCol)).Interior.ColorIndex = xlNone

    With ws.Range(ws.Cells(FIRST_ROW, FIRST_COL), ws.Cells(lastRow, lastCol))
        .ClearContents
        .Interior.ColorIndex = xlNone
    End With

    ' 罫線も消す。作業が減ったとき、前回の横線が下に残ってしまうため
    ws.Range(ws.Cells(MONTH_ROW, FIRST_COL), _
             ws.Cells(lastRow, lastCol)).Borders.LineStyle = xlNone
    ws.Range(ws.Cells(WEEK_ROW, 2), ws.Cells(lastRow, 4)).Borders.LineStyle = xlNone
    ws.Range(ws.Cells(FIRST_ROW, 2), ws.Cells(lastRow, 4)).ClearContents

    ' 行の高さも標準に戻す。作業が減ったとき、前回の高さがそのまま残るため
    ws.Rows(FIRST_ROW & ":" & lastRow).UseStandardHeight = True
End Sub

'==== 縦線を1本引く ====
Private Sub VLine(ws As Worksheet, col As Long, lastRow As Long, lineColor As Long)
    With ws.Range(ws.Cells(MONTH_ROW, col), ws.Cells(lastRow, col)).Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Color = lineColor
        .Weight = xlThin
    End With
End Sub

'==== マス目・見出しの下線・作業の区切り線（全体工程・詳細工程で共通）====
Private Sub GridBorders(ws As Worksheet, jobCount As Long, lastCol As Long)
    Dim lastRow As Long, k As Long, n As Long, sepRow As Long
    Dim edges As Variant

    lastRow = FIRST_ROW + jobCount * ROWS_PER_JOB - 1

    ' 1) まず全体に細いマス目を敷く
    '    消す範囲と引く範囲を必ず同じにする。ここを FIRST_ROW から始めると、
    '    見出しの行の罫線を消したまま引き直さないことになる
    edges = Array(xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight, _
                  xlInsideVertical, xlInsideHorizontal)
    For k = 0 To UBound(edges)
        With ws.Range(ws.Cells(MONTH_ROW, FIRST_COL), _
                      ws.Cells(lastRow, lastCol)).Borders(edges(k))
            .LineStyle = xlContinuous
            .Color = RGB(216, 222, 230)
            .Weight = xlHairline
        End With
    Next k

    ' 2) 見出しの下に1本（B列から右端まで）
    With ws.Range(ws.Cells(WEEK_ROW, 2), _
                  ws.Cells(WEEK_ROW, lastCol)).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Color = RGB(22, 50, 79)
        .Weight = xlMedium
    End With

    ' 3) 作業のまとまりごとに1本、少し濃い横線
    For n = 1 To jobCount
        sepRow = FIRST_ROW + n * ROWS_PER_JOB - 1
        With ws.Range(ws.Cells(sepRow, 2), _
                      ws.Cells(sepRow, lastCol)).Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Color = RGB(100, 116, 139)
            .Weight = xlThin
        End With
    Next n
End Sub

'==== 全体工程の罫線を引く ====
Private Sub DrawBorders(ws As Worksheet, jobCount As Long, baseDate As Date)
    Dim lastRow As Long, i As Long

    lastRow = FIRST_ROW + jobCount * ROWS_PER_JOB - 1
    GridBorders ws, jobCount, FIRST_COL + DAY_COUNT - 1

    ' 月曜の左に縦線を入れて、週の区切りを見せる
    For i = 0 To DAY_COUNT - 1
        If Weekday(baseDate + i, vbMonday) = 1 Then
            VLine ws, FIRST_COL + i, lastRow, RGB(148, 163, 184)
        End If
    Next i

    VLine ws, FIRST_COL, lastRow, RGB(100, 116, 139)
End Sub

'==== 列の名前から位置を探す。無ければ 0 を返す ====
Private Function ColIndex(lo As ListObject, colName As String) As Long
    Dim k As Long
    ColIndex = 0
    For k = 1 To lo.ListColumns.Count
        If lo.ListColumns(k).Name = colName Then ColIndex = k
    Next k
End Function

'==== 作業の開始・終了を「日付＋時間」の1つの値にして返す ====
Private Function JobStart(lo As ListObject, n As Long) As Date
    JobStart = Int(lo.ListColumns("開始日").DataBodyRange.Cells(n).Value) + _
               CDbl(lo.ListColumns("開始時間").DataBodyRange.Cells(n).Value)
End Function

Private Function JobEnd(lo As ListObject, n As Long) As Date
    JobEnd = Int(lo.ListColumns("終了日").DataBodyRange.Cells(n).Value) + _
             CDbl(lo.ListColumns("終了時間").DataBodyRange.Cells(n).Value)
End Function

'==== その日の詳細工程を描く ====
Public Sub DrawDaily()
    Dim ws As Worksheet
    Dim lo As ListObject
    Dim theDate As Date
    Dim i As Long, n As Long, k As Long, cnt As Long
    Dim lastRow As Long
    Dim titleRow As Long, barRow As Long
    Dim sVal As Date, eVal As Date
    Dim sh As Long, eh As Long
    Dim idx() As Long
    Dim memoCol As Long
    Dim memo As String

    Set ws = ThisWorkbook.Worksheets(DAILY_SHEET)
    Set lo = ThisWorkbook.Worksheets(LIST_SHEET).ListObjects(TABLE_NAME)

    ' 時間の列が無いと日をまたぐ判定ができないので、ここで止める
    If ColIndex(lo, "開始時間") = 0 Or ColIndex(lo, "終了時間") = 0 Then
        MsgBox "作業リストに「開始時間」「終了時間」の列がありません。", vbExclamation
        Exit Sub
    End If

    theDate = Int(ws.Range(DAILY_CELL).Value)
    memoCol = ColIndex(lo, "備考")

    Application.ScreenUpdating = False

    ClearArea ws, HOUR_COUNT

    ' 1) その日にかかっている作業を先に数える。
    '    行の数が決まらないと、塗る範囲も罫線の範囲も決められない
    ReDim idx(1 To lo.ListRows.Count)
    cnt = 0
    For n = 1 To lo.ListRows.Count
        If Int(JobStart(lo, n)) <= theDate And Int(JobEnd(lo, n)) >= theDate Then
            cnt = cnt + 1
            idx(cnt) = n
        End If
    Next n

    lastRow = FIRST_ROW + cnt * ROWS_PER_JOB - 1
    If lastRow < FIRST_ROW Then lastRow = FIRST_ROW

    ' 2) 時刻の目盛りを並べる。日付は B2 に出ているので、ここには書かない
    '    （同じ日付が2か所に出ると、どちらを直せばいいのか分からなくなる）
    ws.Range(DAILY_CELL).NumberFormatLocal = "yyyy/m/d(aaa)"
    For i = 0 To HOUR_COUNT - 1
        ws.Cells(HEAD_ROW, FIRST_COL + i).Value = i
    Next i

    ' 3) 人がいない時間を先に塗る。8時より前・17時以降・昼休み
    For i = 0 To HOUR_COUNT - 1
        If i < WORK_START Or i >= WORK_END Or i = LUNCH_HOUR Then
            ws.Range(ws.Cells(WEEK_ROW, FIRST_COL + i), _
                     ws.Cells(lastRow, FIRST_COL + i)).Interior.Color = RGB(231, 226, 216)
        End If
    Next i

    ' 4) その上にバーを重ねる
    For k = 1 To cnt
        n = idx(k)
        titleRow = FIRST_ROW + (k - 1) * ROWS_PER_JOB
        barRow = titleRow + 1

        ws.Rows(titleRow).RowHeight = H_TITLE
        ws.Rows(barRow).RowHeight = H_BAR
        ws.Rows(barRow + 1).RowHeight = H_GAP

        sVal = JobStart(lo, n)
        eVal = JobEnd(lo, n)

        ws.Cells(titleRow, 2).Value = _
            lo.ListColumns("作業内容").DataBodyRange.Cells(n).Value

        ' その日の中での開始と終了。前の日から続いていれば0時から、
        ' 次の日へ続くなら24時まで。ここが日をまたぐ作業の扱いになる
        If Int(sVal) = theDate Then sh = Hour(sVal) Else sh = 0
        If Int(eVal) = theDate Then eh = Hour(eVal) Else eh = HOUR_COUNT

        ' 24:00 は時刻として解釈されると日付に化けて #### になる。文字で入れる
        ws.Range(ws.Cells(titleRow, 3), ws.Cells(titleRow, 4)).NumberFormat = "@"
        ws.Cells(titleRow, 3).Value = sh & ":00"
        ws.Cells(titleRow, 4).Value = eh & ":00"

        If eh > sh Then
            ws.Range(ws.Cells(barRow, FIRST_COL + sh), _
                     ws.Cells(barRow, FIRST_COL + eh - 1)).Interior.Color = RGB(15, 118, 110)

            If memoCol > 0 Then
                memo = CStr(lo.ListColumns(memoCol).DataBodyRange.Cells(n).Value)
                If Len(memo) > 0 Then
                    With ws.Cells(titleRow, FIRST_COL + sh)
                        .Value = memo
                        .HorizontalAlignment = xlLeft
                    End With
                End If
            End If
        End If
    Next k

    DrawDailyBorders ws, cnt

    Application.ScreenUpdating = True

    If cnt = 0 Then
        MsgBox Format$(theDate, "m月d日") & " にかかる作業はありません。", vbInformation
    End If
End Sub

'==== 詳細工程の罫線を引く ====
Private Sub DrawDailyBorders(ws As Worksheet, jobCount As Long)
    Dim lastRow As Long

    If jobCount = 0 Then Exit Sub
    lastRow = FIRST_ROW + jobCount * ROWS_PER_JOB - 1
    GridBorders ws, jobCount, FIRST_COL + HOUR_COUNT - 1

    ' 日勤の始まりと終わりに縦線。全体工程の月曜の線と同じ役目
    VLine ws, FIRST_COL + WORK_START, lastRow, RGB(148, 163, 184)
    VLine ws, FIRST_COL + WORK_END, lastRow, RGB(148, 163, 184)
    VLine ws, FIRST_COL, lastRow, RGB(100, 116, 139)
End Sub