t-hom’s diary

主にVBAネタを扱っているブログです。

VBA Excelガントチャート作成マクロ

今回はVBAでExcelガントチャートを作成するマクロを紹介する。
作成したガントチャート自体はマクロに依存せずExcelの基本機能で動作する。

完成すると以下のようなイメージになる。
f:id:t-hom:20200712012937p:plain

大元のアイデアはこちらのYouTube動画を参考にしている。

動画だと英語の解説で結構操作スピードも速い。また、手動で作成しているので毎回再現するのも面倒だ。
テンプレートを作って使いまわしても良いが、それよりもいつでも再現できるVBAコードの形で残しておこうと思って今回マクロ化した。

オリジナルを参考にしつつ私が新たに追加した機能は次のとおり。

  • 現在進行中のタスクを赤い三角でマーク
  • "Phase"で始まるタスク名を太字と色で強調
  • 計画(PLANNED)と実績(ACTUAL)が入力でき、ガントチャートの方でもPLANNEDが背景塗りつぶし、ACTUALが「≫」で表示
  • 現在のSTATUSはPLANNEDとPROGRESSから自動入力され、Delayはオレンジ系、Over Dueは赤系の色で警告
  • テーマカラー使用の為、ページレイアウトの配色から簡単に好みの色合いに変更可能

使い方

コードが非常に長いので先に使い方を説明する。
マクロを実行すると新規ブックに次のようなフォームが作成される。
f:id:t-hom:20200712014604p:plain
テーマカラーを多用しているのでオフィスのバージョンによって異なると思われる。

次に以下の薄黄色で示した箇所を手入力する。(説明のために塗っただけで、実際は白背景)
f:id:t-hom:20200712015425p:plain

このときタスク名にPhaseで始まる名称を使用すると自動的に強調される。

タスクは手動でインデントするとより見やすくなる。
f:id:t-hom:20200712015644p:plain

ページレイアウトタブの配色から好きな色を選択する。
f:id:t-hom:20200712015740p:plain

あとはファイル名を付けて保存すれば完成。
作成されたガントチャートはVBAを使用しないのでxlsxで保存すればOK。

7/12 10:30 追記

土日及び祝日を網掛けする機能を追加した。祝日はAT列に手動で入力する想定。コードも修正済。
f:id:t-hom:20200712103101p:plain

7/25 22:00 バグ修正

Over Dueの計算式が間違っていたので修正

Before

    sh.Range("I8").FormulaR1C1 = "=IF(OR(ISBLANK(RC[-5]),ISBLANK(RC[-4])),""""," _
        & vbLf & Space(4) & "IF(RC[-1]=1,""Completed""," _
        & vbLf & Space(4 * 2) & "IF(AND(RC[-1]=0,RC[-5]>=TODAY()),""Not Started""," _
        & vbLf & Space(4 * 3) & "IF(AND(RC[-1]<1,RC[-4]<=TODAY()),""Over Due""," _
        & vbLf & Space(4 * 4) & "IF((TODAY()-RC[-5])/(RC[-4]-RC[-5]+1)>=RC[-1],""Delay""," _
        & vbLf & Space(4 * 5) & """In Progress"")))))"

After

    sh.Range("I8").FormulaR1C1 = "=IF(OR(ISBLANK(RC[-5]),ISBLANK(RC[-4])),""""," _
        & vbLf & Space(4) & "IF(RC[-1]=1,""Completed""," _
        & vbLf & Space(4 * 2) & "IF(AND(RC[-1]=0,RC[-5]>=TODAY()),""Not Started""," _
        & vbLf & Space(4 * 3) & "IF(AND(RC[-1]<1,RC[-4]<TODAY()),""Over Due""," _
        & vbLf & Space(4 * 4) & "IF((TODAY()-RC[-5])/(RC[-4]-RC[-5]+1)>=RC[-1],""Delay""," _
        & vbLf & Space(4 * 5) & """In Progress"")))))"

コード

今回は条件分岐等が生じない単なる再現系マクロなので、マクロ記録に毛が生えた程度のコードである。
ある程度コード整理はしたものの、プロシージャ分割等は一切しなかった。

NUMBER_OF_TASKSの値がタスクの行数を表すので、ここを変えると任意のタスク数でガントチャートを作成できる。
他に変更を想定したパラメーターは特にない。
※ちなみにWEEKの値は1週間が7日であることを示す定数なので変更してはならない。

Sub CreateGantt()
    Const WEEK As Integer = 7
    Const NUMBER_OF_TASKS As Integer = 100
    
    '#General Setting
    Dim sh As Worksheet
    Set sh = Workbooks.Add.Sheets(1)
    ActiveWindow.DisplayGridlines = False
    With sh.Cells.Font
        .Name = "Meiryo UI"
        .Size = 9
    End With
    
    '#Header Setting
    sh.Range("A1").Value = "Input Project Name Here"
    With sh.Range("A1").Font
        .Size = 22
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = -0.25
    End With
    
    sh.Names.Add "R_ProjectStart", sh.Range("C3")
    sh.Names.Add "R_DisplayWeek", sh.Range("C4")
    
    With sh.Range("R_ProjectStart")
        .Value = Date
        .Offset(0, -1).Value = "Project Start:"
        .Offset(0, -1).HorizontalAlignment = xlRight
    End With
    
    With sh.Range("R_DisplayWeek")
        .Value = 1
        .Offset(0, -1).Value = "Display Week:"
        .Offset(0, -1).HorizontalAlignment = xlRight
    End With
    
    Dim headerCursor As Range: Set headerCursor = sh.Range("A7")
    Dim h
    For Each h In Split(",TASK,ASSIGNED TO,START,END,START,END,PROGRESS,STATUS", ",")
        headerCursor.Value = h
        Set headerCursor = headerCursor.Offset(0, 1)
    Next

    Dim dateCursor As Range: Set dateCursor = headerCursor.Offset(-1, 0)
    dateCursor.Formula = "=R_ProjectStart-WEEKDAY(R_ProjectStart)+1+((R_DisplayWeek-1)*7)"
    dateCursor.NumberFormatLocal = "d"
    With dateCursor.Offset(0, 1)
        .FormulaR1C1 = "=RC[-1]+1"
        .AutoFill Destination:=.Resize(1, WEEK * 5 - 1), Type:=xlFillDefault
    End With
    dateCursor.Resize(1, WEEK * 5).EntireColumn.ColumnWidth = 3
    dateCursor.Resize(2, 1).EntireRow.HorizontalAlignment = xlCenter
    
    Dim weekdayCursor As Range
    Set weekdayCursor = dateCursor.Offset(1, 0)
    With weekdayCursor
        .FormulaR1C1 = "=LEFT(TEXT(R[-1]C,""ddd""),1)"
        .AutoFill Destination:=.Resize(1, 7 * 5), Type:=xlFillDefault
    End With

    Dim weekCursor As Range: Set weekCursor = dateCursor.Offset(-1, 0)
    With weekCursor
        .FormulaR1C1 = "=R[1]C"
        .NumberFormatLocal = "yyyy/m/d;@"
        .Font.Size = 12
        With .Resize(1, WEEK)
            .Merge
            .HorizontalAlignment = xlLeft
            .AutoFill .Resize(1, WEEK * 5)
        End With
    End With
    
    'Paint
    Dim headerRange As Range
    Set headerRange = sh.Range(Cells(headerCursor.Row, 1), headerCursor.Offset(0, WEEK * 5 - 1))
    With headerRange.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0.5
        .PatternTintAndShade = 0
    End With
    headerRange.Font.Color = rgbWhite

    With weekCursor.Resize(1, WEEK * 5).Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = 0.5
        .PatternTintAndShade = 0
    End With
    
    With dateCursor.Resize(1, WEEK * 5).Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = 0.8
        .PatternTintAndShade = 0
    End With

    Dim r As Range
    Set r = weekCursor
    For i = 1 To 5
        With r.Resize(2, WEEK)
            .Borders(xlDiagonalDown).LineStyle = xlNone
            .Borders(xlDiagonalUp).LineStyle = xlNone
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .ThemeColor = 2
                .TintAndShade = 0.5
                .Weight = xlThin
            End With
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .ThemeColor = 2
                .TintAndShade = 0.5
                .Weight = xlThin
            End With
            .Borders(xlEdgeBottom).LineStyle = xlNone
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .ThemeColor = 2
                .TintAndShade = 0.5
                .Weight = xlThin
            End With
            .Borders(xlInsideVertical).LineStyle = xlNone
            .Borders(xlInsideHorizontal).LineStyle = xlNone
        End With
        Set r = r.Offset(0, 1)
    Next
    
    Dim bodyRange As Range
    Set bodyRange = headerRange.Offset(1, 0).Resize(NUMBER_OF_TASKS)
    bodyRange.RowHeight = 16.5
    With bodyRange
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlEdgeLeft).LineStyle = xlNone
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ThemeColor = 2
            .TintAndShade = 0.5
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ThemeColor = 2
            .TintAndShade = 0.5
            .Weight = xlThin
        End With
        .Borders(xlEdgeRight).LineStyle = xlNone
        .Borders(xlInsideVertical).LineStyle = xlNone
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ThemeColor = 2
            .TintAndShade = 0.5
            .Weight = xlThin
        End With
    End With
    
    'Gantt Bar
    Dim ganttRange As Range
    Set ganttRange = weekdayCursor.Offset(1, 0).Resize(NUMBER_OF_TASKS, WEEK * 5)
    ganttRange.FormulaR1C1 = "=IF(AND(RC6<=R6C,R6C<=RC7),""≫"","""")"
    With ganttRange
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    With ganttRange.Font
        .Size = 16
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = -0.5
    End With
    
    With ganttRange
        .FormatConditions.AddColorScale ColorScaleType:=2
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        .FormatConditions(1).ColorScaleCriteria(1).Type = xlConditionValueLowestValue
        With .FormatConditions(1).ColorScaleCriteria(1).FormatColor
            .Color = 2650623
            .TintAndShade = 0
        End With
        .FormatConditions(1).ColorScaleCriteria(2).Type = xlConditionValueHighestValue
        With .FormatConditions(1).ColorScaleCriteria(2).FormatColor
            .Color = 10285055
            .TintAndShade = 0
        End With
        .FormatConditions.Add Type:=xlExpression, Formula1:="=AND($D8<=J$6,J$6<=$E8)"
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorAccent1
            .TintAndShade = 0.25
        End With
        .FormatConditions(1).StopIfTrue = False
    End With

    'Progress Data Bar
    With sh.Range("H8").Resize(NUMBER_OF_TASKS)
        .HorizontalAlignment = xlCenter
        .NumberFormatLocal = "0%"
        .FormatConditions.AddDatabar
        .FormatConditions(.FormatConditions.Count).ShowValue = True
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1)
            .MinPoint.Modify newtype:=xlConditionValueNumber, newvalue:=0
            .MaxPoint.Modify newtype:=xlConditionValueNumber, newvalue:=1
        End With
        With .FormatConditions(1).BarColor
            .ThemeColor = xlThemeColorAccent1
            .TintAndShade = 0.6
        End With
        .FormatConditions(1).BarFillType = xlDataBarFillSolid
        .FormatConditions(1).Direction = xlContext
        .FormatConditions(1).NegativeBarFormat.ColorType = xlDataBarColor
        .FormatConditions(1).BarBorder.Type = xlDataBarBorderNone
        .FormatConditions(1).AxisPosition = xlDataBarAxisAutomatic
        With .FormatConditions(1).AxisColor
            .Color = 0
            .TintAndShade = 0
        End With
        With .FormatConditions(1).NegativeBarFormat.Color
            .Color = 255
            .TintAndShade = 0
        End With
    End With
    
    'Highlight Today
    With ganttRange.Offset(-2, 0).Resize(ganttRange.Rows.Count + 2)
        .FormatConditions.Add Type:=xlExpression, Formula1:="=J$6=TODAY()"
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Borders(xlLeft)
            .LineStyle = xlContinuous
            .Color = -16776961
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .FormatConditions(1).Borders(xlRight)
            .LineStyle = xlContinuous
            .Color = -16776961
            .TintAndShade = 0
            .Weight = xlThin
        End With
        .FormatConditions(1).StopIfTrue = False
    End With
    
    'Scroll Bars
    sh.ScrollBars.Add(weekCursor.Left, weekCursor.Top - 16.5, weekCursor.Resize(1, WEEK * 5).Width, 14).Select
    With Selection
        .Value = 1
        .Min = 1
        .Max = 52
        .SmallChange = 1
        .LargeChange = 10
        .LinkedCell = "R_DisplayWeek"
        .Display3DShading = False
    End With

    sh.Range("I8").FormulaR1C1 = "=IF(OR(ISBLANK(RC[-5]),ISBLANK(RC[-4])),""""," _
        & vbLf & Space(4) & "IF(RC[-1]=1,""Completed""," _
        & vbLf & Space(4 * 2) & "IF(AND(RC[-1]=0,RC[-5]>=TODAY()),""Not Started""," _
        & vbLf & Space(4 * 3) & "IF(AND(RC[-1]<1,RC[-4]<TODAY()),""Over Due""," _
        & vbLf & Space(4 * 4) & "IF((TODAY()-RC[-5])/(RC[-4]-RC[-5]+1)>=RC[-1],""Delay""," _
        & vbLf & Space(4 * 5) & """In Progress"")))))"
    
    sh.Range("I8").AutoFill sh.Range("I8").Resize(NUMBER_OF_TASKS)
    
    'Status Format
    With sh.Range("I8").Resize(NUMBER_OF_TASKS)
        .HorizontalAlignment = xlCenter
        .FormatConditions.Add Type:=xlTextString, String:="Completed", TextOperator:=xlContains
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Font
            .Color = rgbGray
            .TintAndShade = 0
        End With
        With .FormatConditions(1).Interior
            .Color = rgbGainsboro
            .TintAndShade = 0
        End With
        .FormatConditions(1).StopIfTrue = False
        
        .FormatConditions.Add Type:=xlTextString, String:="In Progress", TextOperator:=xlContains
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Font
            .Color = rgbDarkGreen
            .TintAndShade = 0
        End With
        With .FormatConditions(1).Interior
            .Color = rgbHoneydew
            .TintAndShade = 0
        End With
        .FormatConditions(1).StopIfTrue = False
        
        .FormatConditions.Add Type:=xlTextString, String:="Delay", TextOperator:=xlContains
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Font
            .Color = rgbSienna
            .TintAndShade = 0
        End With
        With .FormatConditions(1).Interior
            .Color = rgbBisque
            .TintAndShade = 0
        End With
        .FormatConditions(1).StopIfTrue = False
        
        .FormatConditions.Add Type:=xlTextString, String:="Over Due", TextOperator:=xlContains
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Font
            .Color = rgbFireBrick
            .TintAndShade = 0
        End With
        With .FormatConditions(1).Interior
            .Color = rgbPink
            .TintAndShade = 0
        End With
        .FormatConditions(1).StopIfTrue = False
    
        .FormatConditions.Add Type:=xlTextString, String:="Not Started", TextOperator:=xlContains
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Font
            .Color = rgbDarkGray
            .TintAndShade = 0
        End With
        With .FormatConditions(1).Interior
            .Color = rgbWhite
            .TintAndShade = 0
        End With
        .FormatConditions(1).StopIfTrue = False
    End With
    
    'Format Start End Dates
    With sh.Range("D7:E7").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent3
        .TintAndShade = -0.25
        .PatternTintAndShade = 0
    End With
    
    With sh.Range("F7:G7").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent4
        .TintAndShade = -0.25
        .PatternTintAndShade = 0
    End With

    sh.Range("D6").Value = "PLANNED"
    sh.Range("D6:E6").Merge
    With sh.Range("D6:E6").Font
        .ThemeColor = xlThemeColorAccent3
        .TintAndShade = -0.25
    End With
    
    sh.Range("F6").Value = "ACTUAL"
    sh.Range("F6:G6").Merge
    With sh.Range("F6:G6").Font
        .ThemeColor = xlThemeColorAccent4
        .TintAndShade = -0.25
    End With
    
    With sh.Range("D7:E7,F7:G7").Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With sh.Range("D7:E7,F7:G7").Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = 0
        .Weight = xlThin
    End With

    'Current Task Picker
    With sh.Range("A8").Resize(NUMBER_OF_TASKS)
        .Interior.Color = rgbWhiteSmoke
        .FormulaR1C1 = "=IF(AND(NOT(ISBLANK(RC[3])),RC[7]<1,RC[3]<=TODAY()),""▲"","""")"
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlCenter
        .Orientation = -90
        With .Font
            .Size = 11
            .Color = 192
        End With
    End With

    'Phase Format
    With sh.Range("B8").Resize(NUMBER_OF_TASKS)
        .FormatConditions.Add Type:=xlTextString, String:="Phase", TextOperator:=xlBeginsWith
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Font
            .Bold = True
            .Italic = False
            .ThemeColor = xlThemeColorAccent1
            .TintAndShade = 0
        End With
        .FormatConditions(1).StopIfTrue = False
    End With
    
    sh.Range("D8:G8").Resize(NUMBER_OF_TASKS).NumberFormatLocal = "yyyy/m/d;@"
    
    sh.Columns("A:A").ColumnWidth = 3
    sh.Columns("B:B").ColumnWidth = 35
    sh.Columns("C:C").ColumnWidth = 13
    sh.Columns("H:H").ColumnWidth = 10
    sh.Columns("I:I").ColumnWidth = 10
    
    'Holiday Format
    With sh.Range("J8").Resize(NUMBER_OF_TASKS, WEEK * 5)
        .FormatConditions.Add Type:=xlExpression, Formula1:="=OR(J$7=""S"",NOT(ISNA(VLOOKUP(J$6,$AT:$AT,1,FALSE))))"
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Interior
            .Pattern = xlLightDown
            .PatternColor = 11711154
            .PatternTintAndShade = 0
        End With
        .FormatConditions(1).StopIfTrue = False
    End With
    
    With sh.Range("AT7")
        .Value = "Holidays"
        With .Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0.5
        .PatternTintAndShade = 0
        End With
        With .Font
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0
        End With
    End With

    With sh.Range("AT8").Resize(NUMBER_OF_TASKS)
        .NumberFormatLocal = "yyyy/m/d;@"
        With .Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 13434879
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
    End With
End Sub

当ブログは、amazon.co.jpを宣伝しリンクすることによってサイトが紹介料を獲得できる手段を提供することを目的に設定されたアフィリエイト宣伝プログラムである、 Amazonアソシエイト・プログラムの参加者です。