Option Explicit
'============================================================
' 工程表設定
'
' 最初に一度だけ触るところです。
'
' ① 下の設定を、自分の表に合わせる（変えなくても動きます）
' ② SetupBook を1回実行すると、シートとボタンができあがります
'
' もう1つの「工程表マクロ」は、描くところと書き出すところだけです。
' 開かなくて構いません。
'============================================================
'---- ① シートとテーブルの名前 ----
Public Const SHEET_NAME As String = "全体工程" ' ガントチャートを描くシート
Public Const DAILY_SHEET As String = "詳細工程" ' その日の時間割を描くシート
Public Const LIST_SHEET As String = "作業リスト" ' 作業リストのテーブルがあるシート
Public Const TABLE_NAME As String = "作業リスト" ' テーブルの名前
'---- ② 表のどこに何があるか ----
Public Const START_CELL As String = "B2" ' 全体工程で、表示開始日を選ぶセル
Public Const DAILY_CELL As String = "B2" ' 詳細工程で、表示する日を選ぶセル
Public Const MONTH_ROW As Long = 2 ' 月のラベルを出す行
Public Const HEAD_ROW As Long = 3 ' 日付を並べる行
Public Const WEEK_ROW As Long = 4 ' 曜日の行（=E3 の数式が入っている）
Public Const FIRST_ROW As Long = 5 ' 1件目のタイトル行
Public Const FIRST_COL As Long = 5 ' E列からカレンダーを描く
'---- ③ どれだけ出すか ----
Public Const DAY_COUNT As Long = 60 ' 全体工程を横に何日ぶん出すか
Public Const HOUR_COUNT As Long = 24 ' 詳細工程を0時から何時間ぶん出すか
'---- ④ 見た目（1作業ぶんの高さ）----
Public Const ROWS_PER_JOB As Long = 3 ' タイトル行＋バー行＋隙間行
Public Const H_TITLE As Double = 17 ' タイトル行の高さ
Public Const H_BAR As Double = 13 ' バーの行の高さ（細いほど締まって見える）
Public Const H_GAP As Double = 5 ' すきまの行の高さ
'---- ⑤ 勤務時間（詳細工程で、人がいない時間を塗るため）----
Public Const WORK_START As Long = 8 ' 日勤の始まり
Public Const WORK_END As Long = 17 ' 日勤の終わり
Public Const LUNCH_HOUR As Long = 12 ' 昼休み
'---- ⑥ 書き出し先。無ければ作ります ----
Public Const EXPORT_DIR As String = "C:\Users\Public\工程表\"
'---- ⑦ 最初に入れておくサンプルの分量（土台づくりだけが使う）----
Public Const JOB_COUNT As Long = 9 ' サンプルの作業の数
Public Const PICK_WEEKS As Long = 9 ' 全体工程のドロップダウンに出す週の数
Public Const PICK_DAYS As Long = 33 ' 詳細工程のドロップダウンに出す日数
'---- 土台づくりが「何をしたか」を覚えておく箱。あとでまとめて報告する ----
Private mMade As String ' 作ったもの
Private mKept As String ' もとからあったので触らなかったもの
Private mWarn As String ' こちらでは判断できなかったもの
Option Explicit
'============================================================
' 工程表マクロ
'
' 描くところと、書き出すところだけが入っています。
' 触らなくて構いません。
' 設定と初期設定は「工程表設定」にまとめてあります。
'============================================================
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
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月" を
' 日付だと解釈してしまい、列幅が狭いと ### になるため先に表示形式を文字列にする。
' 書式もここで毎回そろえる。最初の1つだけ手で色を付けたブックだと、
' 月が変わって出てくる2つ目以降が既定の黒のまま残ってしまうため
With ws.Range(ws.Cells(MONTH_ROW, FIRST_COL), _
ws.Cells(MONTH_ROW, FIRST_COL + DAY_COUNT - 1))
.NumberFormat = "@"
.Font.Bold = True
.Font.Size = 9
.Font.Color = RGB(22, 50, 79)
.HorizontalAlignment = xlLeft
End With
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 = MonthLabel(baseDate, i)
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
'==== 月のラベル。次の月初までに何列空いているかで、入る長さを選ぶ ====
' 列幅は3文字ぶんしかないので、月初のすぐ手前から表を始めると
' "2026年9月" が右へはみ出しきれず "2026年" で切れてしまう
Private Function MonthLabel(baseDate As Date, i As Long) As String
Dim gap As Long
' 次にラベルが出る列（次の月の1日）まで、何列あるかを数える
gap = 1
Do While i + gap <= DAY_COUNT - 1
If Day(baseDate + i + gap) = 1 Then Exit Do
gap = gap + 1
Loop
If gap >= 4 Then
MonthLabel = Format$(baseDate + i, "yyyy年m月")
Else
MonthLabel = Format$(baseDate + i, "m月")
End If
End Function
'==== 前回描いた内容を消す（全体工程・詳細工程で共通）====
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
If Int(sVal) = theDate Then sh = Hour(sVal) Else sh = 0
If Int(eVal) = theDate Then eh = Hour(eVal) Else eh = HOUR_COUNT
If eh < HOUR_COUNT And Minute(eVal) > 0 Then eh = eh + 1 ' 端数は切り上げる
3行目は端数の処理です。この表は1時間刻みなので、8時30分のような分は列がありません。Hour は分を切り捨てるので、そのままだと8時30分〜8時45分のように1時間の枠に収まる作業で sh と eh が同じ値になり、バーが1本も描かれません（あとで出てくる If eh > sh Then を通らないためです）。終了だけ切り上げておけば、短い作業でも必ず1マスは出ます。
'==== 作業の開始・終了を「日付＋時間」の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
If eh < HOUR_COUNT And Minute(eVal) > 0 Then eh = eh + 1 ' 端数は切り上げる
' 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
'==== ボタンから呼ぶ入口。全体工程を書き出す ====
Public Sub ExportGantt()
ExportSheet SHEET_NAME
End Sub
'==== ボタンから呼ぶ入口。詳細工程（その日の時間割）を書き出す ====
Public Sub ExportDaily()
ExportSheet DAILY_SHEET
End Sub
'==== 中身。シート名を受け取って、同じフォルダにPDFとExcelで出す ====
Private Sub ExportSheet(sheetName As String)
' 出力先は「工程表設定」の EXPORT_DIR を使う
Dim ws As Worksheet
Dim outWs As Worksheet
Dim baseName As String
Dim outDir As String
Dim ans As VbMsgBoxResult
Dim n As Long
Set ws = ThisWorkbook.Worksheets(sheetName)
outDir = EXPORT_DIR
' 末尾の \ を忘れると、フォルダ名がファイル名の頭にくっついて
' 1つ上のフォルダに出てしまう。忘れても動くようにここで補う
If Right$(outDir, 1) <> "\" Then outDir = outDir & "\"
If Dir(outDir, vbDirectory) = "" Then MkDir outDir
' 受け取ったシート名をそのままファイル名に使う。
' 全体工程なら「20260812_全体工程」、詳細工程なら「20260812_詳細工程」
baseName = Format$(Date, "yyyymmdd") & "_" & sheetName
' 同じ名前がすでにあるかを先に見る。PDFとExcelのどちらか一方でもあれば聞く
If FileExists(outDir & baseName & ".pdf") _
Or FileExists(outDir & baseName & ".xlsx") Then
ans = MsgBox(baseName & " はすでにあります。上書きしますか？" & vbCrLf & vbCrLf & _
"はい … 上書きする" & vbCrLf & _
"いいえ … _2、_3 と番号を付けて別に保存する" & vbCrLf & _
"キャンセル … 書き出しをやめる", _
vbYesNoCancel + vbQuestion, "書き出し")
If ans = vbCancel Then Exit Sub
If ans = vbNo Then
' PDFとExcelの両方が空いている番号まで進める。片方だけで判定すると
' PDFが_2でExcelが_3のようにずれて、どれが同じ書き出しか分からなくなる
n = 2
Do While FileExists(outDir & baseName & "_" & n & ".pdf") _
Or FileExists(outDir & baseName & "_" & n & ".xlsx")
n = n + 1
Loop
baseName = baseName & "_" & n
End If
End If
' このシートだけ別ブックにコピーして、そちらから書き出す
ws.Copy
Set outWs = ActiveWorkbook.Worksheets(1)
' ボタンはコピーにも付いてくる。渡した先にはマクロが無いので押すとエラーになるし、
' 紙にもそのまま出てしまう。コピーのほうから消しておく
Do While outWs.Shapes.Count > 0
outWs.Shapes(1).Delete
Loop
' PDFで出す
outWs.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=outDir & baseName & ".pdf", _
Quality:=xlQualityStandard, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
' Excelで出す
' 上書きしていいかは上で聞いたあとなので、Excelにもう一度聞かせない
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs _
FileName:=outDir & baseName & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
MsgBox "書き出しました。" & vbCrLf & outDir & baseName & ".pdf / .xlsx", vbInformation
End Sub
'==== ファイルがあるかどうかを見るだけの関数 ====
Private Function FileExists(filePath As String) As Boolean
FileExists = (Dir(filePath) <> "")
End Function
'==== 保存先をその場で選びたいとき ====
Public Function AskFolder(defaultPath As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "書き出し先のフォルダを選んでください"
.InitialFileName = defaultPath
If .Show = -1 Then
AskFolder = .SelectedItems(1) & "\"
Else
AskFolder = defaultPath ' キャンセルなら初期値のまま
End If
End With
End Function
Option Explicit
'============================================================
' 工程表設定
'
' 最初に一度だけ触るところです。
'
' ① 下の設定を、自分の表に合わせる（変えなくても動きます）
' ② SetupBook を1回実行すると、シートとボタンができあがります
'
' もう1つの「工程表マクロ」は、描くところと書き出すところだけです。
' 開かなくて構いません。
'============================================================
'---- ① シートとテーブルの名前 ----
Public Const SHEET_NAME As String = "全体工程" ' ガントチャートを描くシート
Public Const DAILY_SHEET As String = "詳細工程" ' その日の時間割を描くシート
Public Const LIST_SHEET As String = "作業リスト" ' 作業リストのテーブルがあるシート
Public Const TABLE_NAME As String = "作業リスト" ' テーブルの名前
'---- ② 表のどこに何があるか ----
Public Const START_CELL As String = "B2" ' 全体工程で、表示開始日を選ぶセル
Public Const DAILY_CELL As String = "B2" ' 詳細工程で、表示する日を選ぶセル
Public Const MONTH_ROW As Long = 2 ' 月のラベルを出す行
Public Const HEAD_ROW As Long = 3 ' 日付を並べる行
Public Const WEEK_ROW As Long = 4 ' 曜日の行（=E3 の数式が入っている）
Public Const FIRST_ROW As Long = 5 ' 1件目のタイトル行
Public Const FIRST_COL As Long = 5 ' E列からカレンダーを描く
'---- ③ どれだけ出すか ----
Public Const DAY_COUNT As Long = 60 ' 全体工程を横に何日ぶん出すか
Public Const HOUR_COUNT As Long = 24 ' 詳細工程を0時から何時間ぶん出すか
'---- ④ 見た目（1作業ぶんの高さ）----
Public Const ROWS_PER_JOB As Long = 3 ' タイトル行＋バー行＋隙間行
Public Const H_TITLE As Double = 17 ' タイトル行の高さ
Public Const H_BAR As Double = 13 ' バーの行の高さ（細いほど締まって見える）
Public Const H_GAP As Double = 5 ' すきまの行の高さ
'---- ⑤ 勤務時間（詳細工程で、人がいない時間を塗るため）----
Public Const WORK_START As Long = 8 ' 日勤の始まり
Public Const WORK_END As Long = 17 ' 日勤の終わり
Public Const LUNCH_HOUR As Long = 12 ' 昼休み
'---- ⑥ 書き出し先。無ければ作ります ----
Public Const EXPORT_DIR As String = "C:\Users\Public\工程表\"
'---- ⑦ 最初に入れておくサンプルの分量（土台づくりだけが使う）----
Public Const JOB_COUNT As Long = 9 ' サンプルの作業の数
Public Const PICK_WEEKS As Long = 9 ' 全体工程のドロップダウンに出す週の数
Public Const PICK_DAYS As Long = 33 ' 詳細工程のドロップダウンに出す日数
'---- 土台づくりが「何をしたか」を覚えておく箱。あとでまとめて報告する ----
Private mMade As String ' 作ったもの
Private mKept As String ' もとからあったので触らなかったもの
Private mWarn As String ' こちらでは判断できなかったもの
'============================================================
' ここから下は「土台づくり」。
' まだ何も無いブックに、シート・テーブル・ボタンを作る。
' 足りないものだけを作るので、2回目以降に実行しても中身は消えない。
' SetupBook を実行するのは最初の1回だけでよい。
'============================================================
Public Sub SetupBook()
mMade = ""
mKept = ""
mWarn = ""
' 途中で止まっても画面の更新が止まったままにならないように、
' エラーの行き先を先に決めてから ScreenUpdating を切る
On Error GoTo TROUBLE
Application.ScreenUpdating = False
EnsureList
EnsureGantt
EnsureDaily
Application.ScreenUpdating = True
' 何も作らなかったなら、描き直す必要もない。ここで終われば一瞬で済む
If Len(mMade) = 0 Then
MsgBox "そろっていました。何も変更していません。" & vbCrLf & vbCrLf & _
"もとからあったもの" & vbCrLf & mKept & Warnings, _
vbInformation, "工程表のセットアップ"
Exit Sub
End If
' 土台ができたので、そのまま1回描いて完成形を見せる
DrawGantt
DrawDaily
ThisWorkbook.Worksheets(SHEET_NAME).Activate
MsgBox "できました。" & vbCrLf & vbCrLf & _
"作ったもの" & vbCrLf & mMade & _
IIf(Len(mKept) > 0, vbCrLf & "もとからあったもの" & vbCrLf & mKept, "") & _
Warnings & vbCrLf & _
"このあと、必ず .xlsm（Excel マクロ有効ブック）で保存してください。" & vbCrLf & _
".xlsx で保存すると、貼り付けたコードが消えます。", _
vbInformation, "工程表のセットアップ"
Exit Sub
TROUBLE:
Application.ScreenUpdating = True
MsgBox "途中で止まりました。" & vbCrLf & vbCrLf & _
"エラー " & Err.Number & "：" & Err.Description, _
vbCritical, "工程表のセットアップ"
End Sub
'============================================================
' 作業リスト。シートとテーブルを別々に見る
'============================================================
Private Sub EnsureList()
Dim ws As Worksheet
Dim isNew As Boolean
Set ws = EnsureSheet(LIST_SHEET, isNew)
If isNew Then
BuildList ws
NoteMade LIST_SHEET & " シート（サンプルの予定つき）"
Else
NoteKept LIST_SHEET & " シート"
End If
' シートがあってもテーブルが無ければ、テーブルだけ作る。
' 「工程表マクロ」は列を名前で探すので、テーブルでないと動かない
If TableExists(TABLE_NAME) Then
If Not isNew Then NoteKept "テーブル「" & TABLE_NAME & "」"
ElseIf ws.Range("A1").Value = "作業内容" Then
MakeTable ws
NoteMade "テーブル「" & TABLE_NAME & "」（もとの表をテーブルにしました）"
ElseIf IsEmptySheet(ws) Then
BuildList ws
MakeTable ws
NoteMade LIST_SHEET & " の中身とテーブル「" & TABLE_NAME & "」"
Else
' 人が作った別の表が入っている。上書きするとその人の予定が消えるので触らない
NoteWarn LIST_SHEET & " のA1が「作業内容」ではありません。" & vbCrLf & _
" 見出しを 作業内容／開始日／開始時間／終了日／終了時間／備考 に直してから、" & vbCrLf & _
" もう一度実行してください。"
End If
End Sub
'============================================================
' 全体工程
'============================================================
Private Sub EnsureGantt()
Dim ws As Worksheet
Dim isNew As Boolean
Dim lastCol As Long
Set ws = EnsureSheet(SHEET_NAME, isNew)
lastCol = FIRST_COL + DAY_COUNT - 1
If isNew Then
BuildGantt ws
NoteMade SHEET_NAME & " シート"
Else
NoteKept SHEET_NAME & " シート"
' シートはあるけれど、動くのに要るものが欠けている場合だけ足す。
' 見た目（色・列幅）は直さない。手で整えた人のものを壊さないため
If Not IsDate(ws.Range("B2").Value) Then
ws.Range("B2").Value = SampleStart
NoteMade SHEET_NAME & " の表示開始日（B2）"
End If
If Len(ws.Cells(WEEK_ROW, FIRST_COL).Formula) = 0 Then
WeekdayRow ws, lastCol
NoteMade SHEET_NAME & " の曜日の行（4行目の数式）"
End If
If Not HasValidation(ws.Range("B2")) Then
DateDropdown ws.Range("B2"), _
"=" & LIST_SHEET & "!$G$2:$G$" & (PICK_WEEKS + 1)
NoteMade SHEET_NAME & " のB2のドロップダウン"
End If
End If
EnsureButton ws, "btnDrawGantt", "工程表を描く", "DrawGantt", 290, 5
EnsureButton ws, "btnExportGantt", "PDFとExcelで出す", "ExportGantt", 422, 5
End Sub
'============================================================
' 詳細工程
'============================================================
Private Sub EnsureDaily()
Dim ws As Worksheet
Dim isNew As Boolean
Set ws = EnsureSheet(DAILY_SHEET, isNew)
If isNew Then
BuildDaily ws
NoteMade DAILY_SHEET & " シート"
Else
NoteKept DAILY_SHEET & " シート"
If Len(ws.Range("AD2").Formula) = 0 And Not IsDate(ws.Range("AD2").Value) Then
DateCandidates ws
NoteMade DAILY_SHEET & " の日付の候補（AD列）"
End If
If Not IsDate(ws.Range("B2").Value) Then
ws.Range("B2").Value = SampleStart + 7
NoteMade DAILY_SHEET & " の表示する日（B2）"
End If
If Not HasValidation(ws.Range("B2")) Then
DateDropdown ws.Range("B2"), "=$AD$2:$AD$" & (PICK_DAYS + 1)
NoteMade DAILY_SHEET & " のB2のドロップダウン"
End If
End If
EnsureButton ws, "btnDrawDaily", "その日の工程を描く", "DrawDaily", 290, 5
EnsureButton ws, "btnExportDaily", "PDFとExcelで出す", "ExportDaily", 422, 5
End Sub
'============================================================
' 中身を作る。ここはシートを新しく作ったときだけ通る
'============================================================
Private Sub BuildList(ws As Worksheet)
Dim jobs As Variant
Dim r As Variant
Dim n As Long
' 見出し。この6つの名前で「工程表マクロ」が列を探すので、変えるなら両方直す
ws.Range("A1").Value = "作業内容"
ws.Range("B1").Value = "開始日"
ws.Range("C1").Value = "開始時間"
ws.Range("D1").Value = "終了日"
ws.Range("E1").Value = "終了時間"
ws.Range("F1").Value = "備考"
' サンプルの作業。日付は「今月1日から何日目か」で入れているので、
' いつ実行しても今月の表になる。中身は自分の予定に書き換える前提
' 作業内容, 開始+日, 開始時, 終了+日, 終了時, 備考
jobs = Array( _
Array("事前準備", 0, 8, 3, 17, "手配と段取り"), _
Array("資材手配", 2, 9, 8, 15, "納期は要確認"), _
Array("足場組立", 6, 8, 7, 12, ""), _
Array("現地作業A", 7, 6, 15, 18, "定時前から開始"), _
Array("仮設電源の敷設", 7, 8, 7, 17, "当日で完了"), _
Array("立会い確認", 7, 13, 7, 15, "社外の方が同席"), _
Array("現地作業B", 13, 8, 23, 17, "Aと3日重なる"), _
Array("検査", 24, 9, 28, 12, "立会いあり"), _
Array("片付け・報告", 29, 8, 32, 15, ""))
For n = 0 To UBound(jobs)
r = jobs(n)
ws.Cells(n + 2, 1).Value = r(0)
ws.Cells(n + 2, 2).Value = SampleStart + r(1)
ws.Cells(n + 2, 3).Value = TimeSerial(r(2), 0, 0)
ws.Cells(n + 2, 4).Value = SampleStart + r(3)
ws.Cells(n + 2, 5).Value = TimeSerial(r(4), 0, 0)
ws.Cells(n + 2, 6).Value = r(5)
Next n
ws.Columns("A").ColumnWidth = 14.8
ws.Columns("B").ColumnWidth = 11.8
ws.Columns("C").ColumnWidth = 9.8
ws.Columns("D").ColumnWidth = 11.8
ws.Columns("E").ColumnWidth = 9.8
ws.Columns("F").ColumnWidth = 16.8
ws.Columns("G").ColumnWidth = 15
ws.Range("B2:B" & (JOB_COUNT + 1)).NumberFormatLocal = "yyyy/m/d"
ws.Range("D2:D" & (JOB_COUNT + 1)).NumberFormatLocal = "yyyy/m/d"
ws.Range("C2:C" & (JOB_COUNT + 1)).NumberFormatLocal = "h:mm"
ws.Range("E2:E" & (JOB_COUNT + 1)).NumberFormatLocal = "h:mm"
ws.Range("B2:E" & (JOB_COUNT + 1)).HorizontalAlignment = xlCenter
HeaderStyle ws.Range("A1:F1")
With ws.Range("A2:F" & (JOB_COUNT + 1)).Font
.Size = 9
.Color = RGB(31, 42, 55)
End With
ws.Range("F2:F" & (JOB_COUNT + 1)).Font.Color = RGB(100, 116, 139)
' 全体工程のドロップダウンに出す候補。1週間ずつずらした日付を並べておく
With ws.Range("G1")
.Value = "表示開始日の候補"
.Font.Bold = True
.Font.Size = 9
.Font.Color = RGB(100, 116, 139)
End With
ws.Range("G2").Value = SampleStart
ws.Range("G3:G" & (PICK_WEEKS + 1)).FormulaR1C1 = "=R[-1]C+7"
With ws.Range("G2:G" & (PICK_WEEKS + 1))
.NumberFormatLocal = "yyyy/m/d"
.HorizontalAlignment = xlCenter
.Font.Size = 9
End With
HideGridlines ws
End Sub
'==== 表をテーブルにする。
' G列（日付の候補）を書いたあとに呼ぶこと。先にテーブルを作ってから
' 隣のG列に書き込むと、テーブルがG列を巻き込んで7列に広がる ====
Private Sub MakeTable(ws As Worksheet)
Dim lo As ListObject
Dim lastRow As Long
' 最終行は作業内容の列から数える
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
If lastRow < 2 Then lastRow = 2
Set lo = ws.ListObjects.Add(xlSrcRange, ws.Range("A1:F" & lastRow), , xlYes)
lo.Name = TABLE_NAME
lo.TableStyle = "TableStyleLight1"
End Sub
Private Sub BuildGantt(ws As Worksheet)
Dim lastCol As Long
lastCol = FIRST_COL + DAY_COUNT - 1
' 列幅の数字は「標準フォントで何文字ぶんか」なので、
' Excelの標準フォントが違う人の画面では見た目の幅も変わる。
' 日付は2桁しか出さないので、3文字ぶんあれば足りる
ws.Columns("A").ColumnWidth = 5
ws.Columns("B").ColumnWidth = 20
ws.Columns("C:D").ColumnWidth = 2.44
ws.Range(ws.Columns(FIRST_COL), ws.Columns(lastCol)).ColumnWidth = 3.22
ws.Rows(1).RowHeight = 16.2
ws.Rows(MONTH_ROW).RowHeight = 14.4
ws.Rows(WEEK_ROW).RowHeight = 15
With ws.Range("B1")
.Value = "VBA版｜表示開始日を選んで［工程表を描く］"
.Font.Bold = True
.Font.Size = 12
.Font.Color = RGB(22, 50, 79)
End With
With ws.Range("A2")
.Value = "開始"
.Font.Size = 8
.Font.Color = RGB(100, 116, 139)
.HorizontalAlignment = xlCenter
End With
' 表示開始日。ここを変えて［工程表を描く］を押すと、表が丸ごとずれる
With ws.Range("B2")
.Value = SampleStart
.NumberFormatLocal = "yyyy/m/d(aaa)"
.Font.Bold = True
.Font.Size = 10
.Font.Color = RGB(22, 50, 79)
.Interior.Color = RGB(233, 162, 59)
.HorizontalAlignment = xlCenter
End With
DateDropdown ws.Range("B2"), "=" & LIST_SHEET & "!$G$2:$G$" & (PICK_WEEKS + 1)
' 見出しの帯。色はここで付けておく。
' DrawGantt は3行目の「値だけ」を消すので、この色は描き直しても残る
ws.Range("B3").Value = "作業内容"
HeaderStyle ws.Range("B3:B4")
HeaderStyle ws.Range(ws.Cells(HEAD_ROW, FIRST_COL), ws.Cells(HEAD_ROW, lastCol))
ws.Range(ws.Cells(HEAD_ROW, FIRST_COL), _
ws.Cells(HEAD_ROW, lastCol)).NumberFormatLocal = "d"
' 月のラベルの行。左詰めにしておかないと、月名が右隣にはみ出して表示できない
With ws.Range(ws.Cells(MONTH_ROW, FIRST_COL), ws.Cells(MONTH_ROW, lastCol))
.NumberFormat = "@"
.Font.Bold = True
.Font.Size = 9
.Font.Color = RGB(22, 50, 79)
.HorizontalAlignment = xlLeft
End With
WeekdayRow ws, lastCol
' 印刷。横幅を1枚に収め、縦は何枚になってもよい設定。
' Zoom = False にしないと FitToPagesWide が効かない（倍率指定が優先される）。
' ただし60日ぶんを1枚に押し込むと字が小さくなる。実際には表示日数を減らすか、
' 期間を区切って刷ることになる
With ws.PageSetup
.Orientation = xlLandscape
.PaperSize = xlPaperA4
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintTitleColumns = "$A:$D"
End With
FreezeAt ws, "E5"
HideGridlines ws
End Sub
Private Sub BuildDaily(ws As Worksheet)
Dim lastCol As Long
lastCol = FIRST_COL + HOUR_COUNT - 1
ws.Columns("A").ColumnWidth = 2.33
ws.Columns("B").ColumnWidth = 16.8
ws.Columns("C:D").ColumnWidth = 6.8
ws.Range(ws.Columns(FIRST_COL), ws.Columns(lastCol)).ColumnWidth = 4.22
ws.Rows(1).RowHeight = 25.95
ws.Rows(MONTH_ROW).RowHeight = 15
ws.Rows(HEAD_ROW).RowHeight = 15
ws.Rows(WEEK_ROW).RowHeight = 7.95
With ws.Range("B1")
.Value = "詳細工程｜日付を選んで［その日の工程を描く］"
.Font.Bold = True
.Font.Size = 12
.Font.Color = RGB(22, 50, 79)
End With
DateCandidates ws
' 表示する日。最初は1週間後にしておく（サンプルの作業が重なっている日）
With ws.Range("B2")
.Value = SampleStart + 7
.NumberFormatLocal = "yyyy/m/d(aaa)"
.Font.Bold = True
.Font.Size = 9
.Interior.Color = RGB(245, 180, 76)
.HorizontalAlignment = xlCenter
End With
DateDropdown ws.Range("B2"), "=$AD$2:$AD$" & (PICK_DAYS + 1)
ws.Range("B3").Value = "作業内容"
ws.Range("C3").Value = "開始"
ws.Range("D3").Value = "終了"
HeaderStyle ws.Range(ws.Cells(HEAD_ROW, 2), ws.Cells(HEAD_ROW, lastCol))
' こちらは24時間ぶんしかないので、幅を1枚に合わせても字がつぶれない
With ws.PageSetup
.Orientation = xlLandscape
.PaperSize = xlPaperA4
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintTitleColumns = "$A:$D"
End With
HideGridlines ws
End Sub
'==== ドロップダウンの中身。使う人には見せないのでAD列は隠す ====
Private Sub DateCandidates(ws As Worksheet)
With ws.Range("AD1")
.Value = "日付の候補"
.Font.Bold = True
.Font.Size = 9
.Font.Color = RGB(100, 116, 139)
End With
ws.Columns("AD").ColumnWidth = 12.8
ws.Range("AD2").Value = SampleStart
ws.Range("AD3:AD" & (PICK_DAYS + 1)).FormulaR1C1 = "=R[-1]C+1"
ws.Range("AD2:AD" & (PICK_DAYS + 1)).NumberFormatLocal = "yyyy/m/d"
ws.Columns("AD").Hidden = True
End Sub
'============================================================
' ここから下は道具
'============================================================
'==== サンプルの起点。今月の1日。
' DrawGantt の中の baseDate と紛らわしいので別の名前にしている ====
Private Function SampleStart() As Date
SampleStart = DateSerial(Year(Date), Month(Date), 1)
End Function
'==== シートを返す。無ければ足して、足したことを isNew で知らせる ====
Private Function EnsureSheet(sheetName As String, isNew As Boolean) As Worksheet
Dim ws As Worksheet
isNew = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name = sheetName Then
Set EnsureSheet = ws
Exit Function
End If
Next ws
Set ws = ThisWorkbook.Worksheets.Add( _
After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
ws.Name = sheetName
isNew = True
Set EnsureSheet = ws
End Function
'==== その名前のテーブルがブックのどこかにあるか ====
Private Function TableExists(tblName As String) As Boolean
Dim ws As Worksheet
Dim lo As ListObject
For Each ws In ThisWorkbook.Worksheets
For Each lo In ws.ListObjects
If lo.Name = tblName Then
TableExists = True
Exit Function
End If
Next lo
Next ws
End Function
'==== その名前のボタンがそのシートにあるか ====
Private Function ShapeExists(ws As Worksheet, shapeName As String) As Boolean
Dim k As Long
For k = 1 To ws.Shapes.Count
If ws.Shapes(k).Name = shapeName Then
ShapeExists = True
Exit Function
End If
Next k
End Function
'==== 入力規則が入っているか。
' 入っていないセルの .Validation.Type は
' 値を返さずエラーになるので、エラーが出るかどうかで見る ====
Private Function HasValidation(c As Range) As Boolean
Dim t As Long
On Error Resume Next
t = c.Validation.Type
HasValidation = (Err.Number = 0)
Err.Clear
On Error GoTo 0
End Function
'==== 何も入っていないシートか ====
Private Function IsEmptySheet(ws As Worksheet) As Boolean
IsEmptySheet = (Application.WorksheetFunction.CountA(ws.Cells) = 0)
End Function
'==== 日付のドロップダウンを付ける ====
Private Sub DateDropdown(c As Range, listFormula As String)
c.Validation.Delete
c.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Formula1:=listFormula
End Sub
'==== 曜日の行。真上の日付を見るだけの数式を並べる。
' これがあるので、VBA側で曜日を書かなくて済む ====
Private Sub WeekdayRow(ws As Worksheet, lastCol As Long)
With ws.Range(ws.Cells(WEEK_ROW, FIRST_COL), ws.Cells(WEEK_ROW, lastCol))
.FormulaR1C1 = "=R[-1]C"
.NumberFormatLocal = "aaa"
.Font.Size = 8
.Font.Color = RGB(100, 116, 139)
.HorizontalAlignment = xlCenter
End With
End Sub
'==== 見出しの帯（濃い紺に白抜き）====
Private Sub HeaderStyle(target As Range)
With target
.Font.Bold = True
.Font.Size = 9
.Font.Color = RGB(255, 255, 255)
.Interior.Color = RGB(22, 50, 79)
.HorizontalAlignment = xlCenter
End With
End Sub
'==== ボタンを1つ置く。もうあるなら何もしない ====
Private Sub EnsureButton(ws As Worksheet, btnName As String, btnCaption As String, _
macroName As String, L As Double, T As Double)
Dim b As Object
If ShapeExists(ws, btnName) Then
NoteKept ws.Name & " の［" & btnCaption & "］ボタン"
Exit Sub
End If
Set b = ws.Buttons.Add(L, T, 126, 24)
b.Name = btnName
b.Caption = btnCaption
b.OnAction = macroName
NoteMade ws.Name & " の［" & btnCaption & "］ボタン"
End Sub
'==== 見出しを固定する。画面の設定なので、ここだけシートを表に出す必要がある ====
Private Sub FreezeAt(ws As Worksheet, cellAddress As String)
ws.Activate
ActiveWindow.FreezePanes = False
ws.Range(cellAddress).Select
ActiveWindow.FreezePanes = True
End Sub
'==== 目盛線を消す。これも画面の設定 ====
Private Sub HideGridlines(ws As Worksheet)
ws.Activate
ActiveWindow.DisplayGridlines = False
End Sub
'==== 何をしたかを覚えておく ====
Private Sub NoteMade(msg As String)
mMade = mMade & "・" & msg & vbCrLf
End Sub
Private Sub NoteKept(msg As String)
mKept = mKept & "・" & msg & vbCrLf
End Sub
Private Sub NoteWarn(msg As String)
mWarn = mWarn & "・" & msg & vbCrLf
End Sub
Private Function Warnings() As String
If Len(mWarn) = 0 Then Exit Function
Warnings = vbCrLf & "こちらでは決められなかったもの" & vbCrLf & mWarn
End Function
完成版② 工程表マクロ（2つ目のモジュールに貼る）
Option Explicit
'============================================================
' 工程表マクロ
'
' 描くところと、書き出すところだけが入っています。
' 触らなくて構いません。
' 設定と初期設定は「工程表設定」にまとめてあります。
'============================================================
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
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月" を
' 日付だと解釈してしまい、列幅が狭いと ### になるため先に表示形式を文字列にする。
' 書式もここで毎回そろえる。最初の1つだけ手で色を付けたブックだと、
' 月が変わって出てくる2つ目以降が既定の黒のまま残ってしまうため
With ws.Range(ws.Cells(MONTH_ROW, FIRST_COL), _
ws.Cells(MONTH_ROW, FIRST_COL + DAY_COUNT - 1))
.NumberFormat = "@"
.Font.Bold = True
.Font.Size = 9
.Font.Color = RGB(22, 50, 79)
.HorizontalAlignment = xlLeft
End With
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 = MonthLabel(baseDate, i)
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
'==== 月のラベル。次の月初までに何列空いているかで、入る長さを選ぶ ====
' 列幅は3文字ぶんしかないので、月初のすぐ手前から表を始めると
' "2026年9月" が右へはみ出しきれず "2026年" で切れてしまう
Private Function MonthLabel(baseDate As Date, i As Long) As String
Dim gap As Long
' 次にラベルが出る列（次の月の1日）まで、何列あるかを数える
gap = 1
Do While i + gap <= DAY_COUNT - 1
If Day(baseDate + i + gap) = 1 Then Exit Do
gap = gap + 1
Loop
If gap >= 4 Then
MonthLabel = Format$(baseDate + i, "yyyy年m月")
Else
MonthLabel = Format$(baseDate + i, "m月")
End If
End Function
'==== 前回描いた内容を消す（全体工程・詳細工程で共通）====
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
If eh < HOUR_COUNT And Minute(eVal) > 0 Then eh = eh + 1 ' 端数は切り上げる
' 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
'==== ボタンから呼ぶ入口。全体工程を書き出す ====
Public Sub ExportGantt()
ExportSheet SHEET_NAME
End Sub
'==== ボタンから呼ぶ入口。詳細工程（その日の時間割）を書き出す ====
Public Sub ExportDaily()
ExportSheet DAILY_SHEET
End Sub
'==== 中身。シート名を受け取って、同じフォルダにPDFとExcelで出す ====
Private Sub ExportSheet(sheetName As String)
' 出力先は「工程表設定」の EXPORT_DIR を使う
Dim ws As Worksheet
Dim outWs As Worksheet
Dim baseName As String
Dim outDir As String
Dim ans As VbMsgBoxResult
Dim n As Long
Set ws = ThisWorkbook.Worksheets(sheetName)
outDir = EXPORT_DIR
' 末尾の \ を忘れると、フォルダ名がファイル名の頭にくっついて
' 1つ上のフォルダに出てしまう。忘れても動くようにここで補う
If Right$(outDir, 1) <> "\" Then outDir = outDir & "\"
If Dir(outDir, vbDirectory) = "" Then MkDir outDir
' 受け取ったシート名をそのままファイル名に使う。
' 全体工程なら「20260812_全体工程」、詳細工程なら「20260812_詳細工程」
baseName = Format$(Date, "yyyymmdd") & "_" & sheetName
' 同じ名前がすでにあるかを先に見る。PDFとExcelのどちらか一方でもあれば聞く
If FileExists(outDir & baseName & ".pdf") _
Or FileExists(outDir & baseName & ".xlsx") Then
ans = MsgBox(baseName & " はすでにあります。上書きしますか？" & vbCrLf & vbCrLf & _
"はい … 上書きする" & vbCrLf & _
"いいえ … _2、_3 と番号を付けて別に保存する" & vbCrLf & _
"キャンセル … 書き出しをやめる", _
vbYesNoCancel + vbQuestion, "書き出し")
If ans = vbCancel Then Exit Sub
If ans = vbNo Then
' PDFとExcelの両方が空いている番号まで進める。片方だけで判定すると
' PDFが_2でExcelが_3のようにずれて、どれが同じ書き出しか分からなくなる
n = 2
Do While FileExists(outDir & baseName & "_" & n & ".pdf") _
Or FileExists(outDir & baseName & "_" & n & ".xlsx")
n = n + 1
Loop
baseName = baseName & "_" & n
End If
End If
' このシートだけ別ブックにコピーして、そちらから書き出す
ws.Copy
Set outWs = ActiveWorkbook.Worksheets(1)
' ボタンはコピーにも付いてくる。渡した先にはマクロが無いので押すとエラーになるし、
' 紙にもそのまま出てしまう。コピーのほうから消しておく
Do While outWs.Shapes.Count > 0
outWs.Shapes(1).Delete
Loop
' PDFで出す
outWs.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=outDir & baseName & ".pdf", _
Quality:=xlQualityStandard, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
' Excelで出す
' 上書きしていいかは上で聞いたあとなので、Excelにもう一度聞かせない
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs _
FileName:=outDir & baseName & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
MsgBox "書き出しました。" & vbCrLf & outDir & baseName & ".pdf / .xlsx", vbInformation
End Sub
'==== ファイルがあるかどうかを見るだけの関数 ====
Private Function FileExists(filePath As String) As Boolean
FileExists = (Dir(filePath) <> "")
End Function
'==== 保存先をその場で選びたいとき ====
Public Function AskFolder(defaultPath As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "書き出し先のフォルダを選んでください"
.InitialFileName = defaultPath
If .Show = -1 Then
AskFolder = .SelectedItems(1) & "\"
Else
AskFolder = defaultPath ' キャンセルなら初期値のまま
End If
End With
End Function
マクロを有効にしても動きません。
ファイルをメールや共有リンクで受け取った場合、Officeが既定でマクロをブロックします。バージョン2206以降の動作で、インターネット由来のファイルには Windows が印（Mark of the Web）を付けるためです。この場合は「セキュリティリスク」のバナーが出て、そもそも有効化ボタンが出ません。
