アローダイアグラムの作成 with Excel VBA(ver.2013 or later)
アウトライン
アローダイアグラム(PERT図)の手描きのドラフトをもとに,Excelでアローダイアグラムを作成します。
[ドラフト※]
※[PDF]基本情報技術者試験(平成22年度秋期試験)午前・問52 を引用して作成
[Excel によるアウトプット]
このアウトプットには,矢印をアクティビティとする形式を用います(Activity on Arrow)。
描画に際し,ノードごとに最早開始時刻(ES)・最遅開始時刻(LS)・余裕時間(TF)を求めこれらをあわせて表示します。
また |クリティカルパス|ダミーアクティビティ|作業名| の描画はデフォルトでONですが,これらの機能はコード先頭の定数部分をFALSEに変えることで排除することが可能です。
仕様
- 散布図を素地にして図を描きます。アローおよび各種ラベルはそれぞれ単独の系列を消費して表示します。したがってエクセルの仕様上の系列数の上限(255)以内で図のすべての要素が描ける場合のみ正常に機能します。
- ノード番号 ないし ノード記号は必須です。
- アクティビティの流れ(矢印の向き)と ノード番号ないしノード記号の序列とが矛盾する場合,このマクロは正常に機能しません(たとえば⑤→④のような., cf.アローダイアグラムを記述するうえでのルール)。
- 入力データに関して,整合を確認するしくみをもちません。このマクロは,入力されたデータのすべてに矛盾がないものとみなして処理をおこないます。
免責および特記事項
- アウトプットに矛盾がないか,いくつかのパターンを使って確認をおこなっていますが,筆者による数式・コードの構成,ないしは筆者にとって想定の至らない事象などを原因に不正確が生じる可能性を排除するものではありません。筆者はこれによってユーザーが被った不利益に対しいかなる責任も負いかねますので,そのあたりの精密さが不可欠な場合には,他の処理系のご利用をおすすめします。
アローダイアグラムの作成
Step 1元表の作成(1)―ノードの定義
次のような見出しをA1のセルから用意します。
見出し「ノード」の下には,利用するノード番号(1, 2, 3, ... など)ないしは記号(A, B, C, ... など)を入力しておきます。
Step 2元表の作成(2)―ノード座標の作成
ノードの位置を目安にして ドラフトにグリッドを作成し,
縦横のグリッド線に番号を付加します。横軸の番号は最も左の線を1,縦軸の番号は(見た目上)軸となる線を0として番号を振っていくと感覚的に容易かと思います。
すべてのノードの位置を直交座標によりシート上に示します。細かな調整はあとからでも可能なので,この時点ではアバウトでOKです。
- Nx ― X(横)座標
- Ny ― Y(縦)座標
Step 3元表の作成(3)―先行ノードの指示
各ノードの先行ノード(直前のノード)を指示します。
開始ノードを除くすべてのノードに関して,そのノードに先行する関係にある1つ以上のノード番号あるいはノード記号を指定します。複数にわたる場合は,順に右隣の別のセルへと1つずつ入力していきます。
Step 4VBEの操作・VBAコードの導入(1)―コードのコピー
次のコードをすべて選択し,コピーします。
Const OPT1 As Boolean = True ' クリティカルパスを明示するか Const OPT2 As Boolean = True ' ダミーアクティビティを破線表示にするか Const OPT3 As Boolean = True ' 作業名を表示するか Sub ARROWDIAGRAM1_preprocess() ' *** アローダイアグラムの作成|前処理 v17.730 ' *** bdastyle.net/tools/project-management/arrow-diagram.html ' *** by hawcas 2015, 2017 Dim num_ROW As Long ' 下端行番号 Dim num_COL As Long ' 右端列番号 Dim sumtotal_PREVNODE As Long ' 総先行ノード数 Dim adr_DATATABLE As Range ' Rangeオブジェクト Dim adr_ACTIVITY As Range Dim adr_PARAM As Range Dim adr_TIME As Range Dim TARGET As String ' ノード座標のデータ範囲 Dim wdArray() As Variant ' 見出し作成のための配列 Dim cdRange(2) As Variant ' 座標のレンジ Dim TMP As Variant Dim x As Long ' 以下カウンタ Dim y As Long Application.ScreenUpdating = False TMP = ActiveSheet.Name ' シートをコピー Worksheets(TMP).Copy after:=Worksheets(TMP) num_COL = 0 num_ROW = 0 num_ROW = rowMax() ' [node]下端の行番号を求める num_COL = colMax(num_ROW) ' [node]右端の列番号を求める sumtotal_PREVNODE = preNodes(num_ROW, num_COL) ' [node]先行ノードの総数を求める Set adr_DATATABLE = Cells(1, 1) ' [node]表の基点を格納 Set adr_PARAM = adr_DATATABLE.Offset(0, num_COL + 1) ' [adjust]表の基点を格納 Set adr_ACTIVITY = adr_PARAM.Offset(3, 0) ' [activity]表の基点を格納 Set adr_TIME = adr_ACTIVITY.Offset(sumtotal_PREVNODE + 2, 0) ' [time]表の基点を格納 ReDim wdArray(5) ' [adjust]表の見出しと初期値を設置 With adr_DATATABLE cdRange(0) = Application.WorksheetFunction.Max( _ Range(.Offset(1, 1), .Offset(num_ROW - 1, 1))) - _ Application.WorksheetFunction.Min( _ Range(.Offset(1, 1), .Offset(num_ROW - 1, 1))) ' X range cdRange(1) = Application.WorksheetFunction.Max( _ Range(.Offset(1, 2), .Offset(num_ROW - 1, 2))) - _ Application.WorksheetFunction.Min( _ Range(.Offset(1, 2), .Offset(num_ROW - 1, 2))) ' Y range cdRange(2) = Application.WorksheetFunction.Max(cdRange(0), cdRange(1)) End With wdArray = Array("間隙", cdRange(2) * 0.05, "距離", cdRange(2) * 0.05, "間隔", cdRange(2) * 0.04) For x = 0 To 5 Step 2 adr_PARAM.Offset(0, x).Value = wdArray(x) adr_PARAM.Offset(1, x).Value = wdArray(x + 1) Next ReDim wdArray(7) ' [activity]表の見出しを設置 adr_ACTIVITY.Offset(0, 0).Value = "Activity" wdArray = Array("SPx", "SPy", "EPx", "EPy", "作業名", "所要時間", "Tx", "Ty") ' cf) ' SPx: エッジの始点x座標 ' SPy: エッジの始点y座標 ' EPx: エッジの終点x座標 ' EPy: エッジの終点y座標 ' Tx: 所要時間のx座標 ' Ty: 所要時間のy座標 For x = 0 To 7 adr_ACTIVITY.Offset(0, x + 3).Value = wdArray(x) Next ReDim wdArray(9) ' [time]表見出しを設置 wdArray = Array("Node", "ES", "LS", "TF", "LabESx", "LabESy", "LabLSx", "LabLSy", "LabTFx", "LabTFy") ' cf) ' Earlist Starting Time, ES: 最早開始時刻 ' Lastest Starting Time, LS: 最遅開始時刻 ' Total Float, TF: 余裕 For x = 0 To 9 adr_TIME.Offset(0, x).Value = wdArray(x) Next With adr_ACTIVITY ' [activity]表の処理 TARGET = Range(Cells(2, 1), Cells(num_ROW, 3)).Address ' vlookup関数の参照範囲を格納 TMP = 1 For y = 1 To num_ROW ' "m to n" 形式の行見出しを設置 For x = 1 To Application.WorksheetFunction.CountA(Range(adr_DATATABLE.Offset(y, 3), _ adr_DATATABLE.Offset(y, num_COL - 1))) .Offset(TMP, 0).Value = Range("d1").Offset(y, x - 1).Value .Offset(TMP, 1).Value = "to" .Offset(TMP, 2).Value = adr_DATATABLE.Offset(y, 0).Value TMP = TMP + 1 Next Next Range(adr_ACTIVITY.Offset(1, 0), adr_ACTIVITY.Offset(TMP - 1, 2)).Sort _ key1:=adr_ACTIVITY.Offset(1, 0), order1:=xlAscending, Header:=xlNo ' エッジのソート ReDim wdArray(25) wdArray = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", _ "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z") ' デフォルトの作業名 For y = 1 To sumtotal_PREVNODE ' エッジの始点と終点を求め,その他項目を設置する .Offset(y, 3).Formula = "=vlookup(" & .Offset(y, 0).Address & "," & TARGET & ",2,false)" ' SPx .Offset(y, 4).Formula = "=vlookup(" & .Offset(y, 0).Address & "," & TARGET & ",3,false)" ' SPy .Offset(y, 5).Formula = "=if(" & "vlookup(" & .Offset(y, 0).Address & "," & TARGET & ",2,false)<>vlookup(" & _ .Offset(y, 2).Address & "," & TARGET & ",2,false),vlookup(" & .Offset(y, 2).Address & "," & TARGET & ",2,false)-" & _ adr_PARAM.Offset(1, 0).Address & ",vlookup(" & .Offset(y, 2).Address & "," & TARGET & ",2,false))" ' EPx .Offset(y, 6).Formula = "=if(" & "vlookup(" & .Offset(y, 0).Address & "," & TARGET & ",2,false)<>vlookup(" & _ .Offset(y, 2).Address & "," & TARGET & ",2,false)," & "vlookup(" & .Offset(y, 2).Address & "," & TARGET & ",3,false)," & _ "if(" & "vlookup(" & .Offset(y, 0).Address & "," & TARGET & ",3,false)>vlookup(" & .Offset(y, 2).Address & "," & TARGET & ",3,false)," & _ "vlookup(" & .Offset(y, 2).Address & "," & TARGET & ",3,false)+" & adr_PARAM.Offset(1, 0).Address & "*3/4," & _ "vlookup(" & .Offset(y, 2).Address & "," & TARGET & ",3,false)+(-1)*" & adr_PARAM.Offset(1, 0).Address & "*3/4))" ' EPy .Offset(y, 7).Value = wdArray(y - 1) ' 作業名 .Offset(y, 9).Formula = "=if(" & .Offset(y, 4).Address & "<>" & _ .Offset(y, 6).Address & ",average(" & .Offset(y, 3).Address & "," & _ .Offset(y, 5).Address & "+" & adr_PARAM.Offset(1, 0).Address & _ "),average(" & .Offset(y, 3).Address & "," & .Offset(y, 5).Address & _ "+" & adr_PARAM.Offset(1, 0).Address & "/2))" ' Tx .Offset(y, 10).Formula = "=average(" & .Offset(y, 4).Address & _ "," & .Offset(y, 6).Address & ")" ' Ty Next End With For y = 1 To num_ROW - 1 ' [time]表の処理・ノード番号を転記する adr_TIME.Offset(y, 0).Value = adr_DATATABLE.Offset(y, 0).Value Next Application.ScreenUpdating = True End Sub Sub ARROWDIAGRAM2_draw() ' *** アローダイアグラムの作成|主処理 v17.730 ' *** bdastyle.net/tools/project-management/arrow-diagram.html ' *** by hawcas 2015, 2017 Dim num_ROW As Long ' 下端行番号 Dim num_COL As Long ' 右端列番号 Dim sumtotal_PREVNODE As Long ' 総先行ノード数 Dim adr_DATATABLE As Range ' Rangeオブジェクト Dim adr_ACTIVITY As Range Dim adr_PARAM As Range Dim adr_TIME As Range Dim earliest_NODE() As Variant ' 最早開始時刻 Dim earliest_NODE_Flg() As Boolean Dim latest_NODE() As Variant ' 最遅開始時刻 Dim latest_NODE_Flg() As Boolean Dim lt2num_NODE() As Variant ' ノードのcaptionと識別番号 Dim m As Variant ' m on "m to n" Dim n As Variant ' n on "m to n" Dim TARGET As String ' ノード座標のデータ範囲 Dim ser_CP As String ' 系列のcaption Dim ser_X As String ' 系列のX Dim ser_Y As String ' 系列のY Dim TMP As Variant Dim BUF() As Variant Dim x As Long ' 以下カウンタ Dim y As Long Dim z As Long Application.ScreenUpdating = False num_COL = 0 num_ROW = 0 num_ROW = rowMax() ' [node]下端の行番号を求める num_COL = colMax(num_ROW) ' [node]右端の列番号を求める ReDim lt2num_NODE(num_ROW - 1, 1) ReDim earliest_NODE(num_ROW - 1) ReDim earliest_NODE_Flg(num_ROW - 1) ReDim latest_NODE(num_ROW - 1) ReDim latest_NODE_Flg(num_ROW - 1) For z = 1 To num_ROW - 1 lt2num_NODE(z, 0) = Range("A1").Offset(z, 0).Value ' Caption(ノード名) lt2num_NODE(z, 1) = z ' 識別番号 Next sumtotal_PREVNODE = preNodes(num_ROW, num_COL) ' [node]先行ノードの総数を求める ReDim BUF(sumtotal_PREVNODE - 2) Set adr_DATATABLE = Cells(1, 1) ' [node]表の基点を格納 Set adr_PARAM = adr_DATATABLE.Offset(0, num_COL + 1) ' [adjust]表の基点を格納 Set adr_ACTIVITY = adr_PARAM.Offset(3, 0) ' [activity]表の基点を格納 Set adr_TIME = adr_ACTIVITY.Offset(sumtotal_PREVNODE + 2, 0) ' [time]表の基点を格納 ' ES(最早開始時刻)を求める earliest_NODE(1) = 0 earliest_NODE_Flg(1) = True For y = 1 To sumtotal_PREVNODE For z = 1 To num_ROW - 1 ' m(ノードの識別番号を取得) If lt2num_NODE(z, 0) = adr_ACTIVITY.Offset(y, 0).Value Then m = lt2num_NODE(z, 1) Exit For End If Next For z = 1 To num_ROW - 1 ' n(ノードの識別番号を取得) If lt2num_NODE(z, 0) = adr_ACTIVITY.Offset(y, 2).Value Then n = lt2num_NODE(z, 1) Exit For End If Next Select Case earliest_NODE_Flg(n) ' "m to n" の nフラグを見て Case False ' ノードが固有のES値をもっていなかったら earliest_NODE(n) = earliest_NODE(m) + adr_ACTIVITY.Offset(y, 8).Value ' TIMEを加え earliest_NODE_Flg(n) = True ' フラグをON Case True ' ノードが固有のES値をもっていたら If earliest_NODE(n) < earliest_NODE(m) + adr_ACTIVITY.Offset(y, 8).Value Then earliest_NODE(n) = earliest_NODE(m) + adr_ACTIVITY.Offset(y, 8).Value ' あらたに求めたES値の方が大きいときのみそれを書き換え End If End Select Next For y = 1 To num_ROW - 1 ' ES値を作成 adr_TIME.Offset(y, 1).Value = earliest_NODE(y) Next ' LS(最遅開始時刻)を求める latest_NODE(num_ROW - 1) = earliest_NODE(num_ROW - 1) latest_NODE_Flg(num_ROW - 1) = True For y = sumtotal_PREVNODE To 1 Step -1 For z = 1 To num_ROW - 1 ' m(ノードの識別番号を取得) If lt2num_NODE(z, 0) = adr_ACTIVITY.Offset(y, 0).Value Then m = lt2num_NODE(z, 1) Exit For End If Next For z = 1 To num_ROW - 1 ' n(ノードの識別番号を取得) If lt2num_NODE(z, 0) = adr_ACTIVITY.Offset(y, 2).Value Then n = lt2num_NODE(z, 1) Exit For End If Next Select Case latest_NODE_Flg(m) ' "m to n" の mフラグを見て Case False ' ノードが固有のLS値をもっていなかったら latest_NODE(m) = latest_NODE(n) - adr_ACTIVITY.Offset(y, 8).Value ' TIMEを減じ latest_NODE_Flg(m) = True ' フラグをON Case True ' ノードが固有のLS値をもっていたら If latest_NODE(m) > latest_NODE(n) - adr_ACTIVITY.Offset(y, 8).Value Then latest_NODE(m) = latest_NODE(n) - adr_ACTIVITY.Offset(y, 8).Value ' あらたに求めたLS値の方が小さいときのみそれを書き換え End If End Select Next For y = num_ROW - 1 To 1 Step -1 ' LS値を作成 adr_TIME.Offset(y, 2).Value = latest_NODE(y) Next ' TF(余裕)を求める For y = 1 To num_ROW - 1 adr_TIME.Offset(y, 3).Formula = "=" & adr_TIME.Offset(y, 2).Address & "-" & adr_TIME.Offset(y, 1).Address ' n-m Next ' [time]表の処理|座標の作成 For y = 1 To num_ROW - 1 With adr_TIME .Offset(y, 4).Formula = "=" & adr_DATATABLE.Offset(y, 1).Address ' LabESx .Offset(y, 5).Formula = "=" & adr_DATATABLE.Offset(y, 2).Address & "+" & adr_PARAM.Offset(1, 2).Address ' LabESy .Offset(y, 6).Formula = "=" & .Offset(y, 4).Address & "+" & adr_PARAM.Offset(1, 4).Address ' LabLSx .Offset(y, 7).Formula = "=" & .Offset(y, 5).Address ' LabLSy .Offset(y, 8).Formula = "=" & .Offset(y, 6).Address & "+" & adr_PARAM.Offset(1, 4).Address ' LabTFx .Offset(y, 9).Formula = "=" & .Offset(y, 7).Address ' LabTFy End With Next ' ~以下グラフの描画 ' [node]系列を敷設 TARGET = Range(Cells(2, 2), Cells(num_ROW, 3)).Address ' ノード座標を範囲指定 With ActiveSheet .ChartObjects.Add Left:=10, Top:=100, Width:=480, Height:=300 ' 素地(グラフフレーム)の位置とサイズを設定 .ChartObjects(1).Chart.ChartType = xlXYScatter .ChartObjects(1).Activate End With ActiveChart.SetSourceData Source:=Range(TARGET) With ActiveSheet.ChartObjects(1).Chart .HasTitle = False .SeriesCollection(1).MarkerSize = 25 ' ノードのサイズ .SeriesCollection(1).MarkerStyle = xlMarkerStyleCircle ' ノードの形状(円) .SeriesCollection(1).HasDataLabels = True ' データラベルをON End With With ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1) .MarkerForegroundColor = RGB(200, 200, 200) ' ノード枠線色 .MarkerBackgroundColor = RGB(200, 200, 200) ' ノード塗り色 End With ser_CP = "" ser_CP = Range("A1").Value ' (セルA1の内容で)系列名を付与 ActiveChart.FullSeriesCollection(1).Name = ser_CP TARGET = "'" & ActiveSheet.Name & "'!" & _ ActiveSheet.Range(Cells(2, 1), Cells(num_ROW, 1)).Address ' ノード名のセル範囲 With ActiveChart .FullSeriesCollection(1).DataLabels.Select .SeriesCollection(1).DataLabels.Format.TextFrame2.TextRange. _ InsertChartField msoChartFieldRange, TARGET, 0 ' [node]データラベルを付与 End With With Selection .ShowRange = True .ShowValue = False .Position = xlLabelPositionCenter ' データラベルをノードの中央に End With ' [activity]系列|エッジを敷設 For z = 1 To sumtotal_PREVNODE ser_CP = "" For x = 0 To 2 ser_CP = ser_CP & adr_ACTIVITY.Offset(z, x).Value ' 系列名を作成 Next ser_X = "" ser_X = "'" & ActiveSheet.Name & "'!" & adr_ACTIVITY.Offset(z, 3).Address & _ ",'" & ActiveSheet.Name & "'!" & adr_ACTIVITY.Offset(z, 5).Address ' x範囲を作成 ser_Y = "" ser_Y = "'" & ActiveSheet.Name & "'!" & adr_ACTIVITY.Offset(z, 4).Address & _ ",'" & ActiveSheet.Name & "'!" & adr_ACTIVITY.Offset(z, 6).Address ' y範囲を作成 With ActiveChart .SeriesCollection.NewSeries .FullSeriesCollection(z + 1).Name = ser_CP ' [activity]系列名を付与 .FullSeriesCollection(z + 1).XValues = ser_X ' x範囲を指定 .FullSeriesCollection(z + 1).Values = ser_Y ' y範囲を指定 .FullSeriesCollection(z + 1).Select End With With Selection .Format.Line.Visible = msoTrue .Format.Line.EndArrowheadStyle = msoArrowheadTriangle ' エッジの突端の形(三角矢尻) .MarkerStyle = -4142 ' マーカーを削除 End With Next ' [activity]系列|作業時間を敷設 TMP = 1 + sumtotal_PREVNODE ' 系列番号初期値=ノード(1)+アクティビティ1set(x) For z = 1 To sumtotal_PREVNODE ser_CP = "" For x = 0 To 2 ser_CP = ser_CP & adr_ACTIVITY.Offset(z, x).Value ' 系列名を作成 Next ser_CP = "WT_" & ser_CP ser_X = "" ser_X = "'" & ActiveSheet.Name & "'!" & adr_ACTIVITY.Offset(z, 9).Address ' x範囲を作成 ser_Y = "" ser_Y = "'" & ActiveSheet.Name & "'!" & adr_ACTIVITY.Offset(z, 10).Address ' y範囲を作成 With ActiveChart .SeriesCollection.NewSeries .FullSeriesCollection(TMP + z).Name = ser_CP ' 系列名を付与 .FullSeriesCollection(TMP + z).XValues = ser_X ' x範囲を指定 .FullSeriesCollection(TMP + z).Values = ser_Y ' y範囲を指定 .FullSeriesCollection(TMP + z).MarkerStyle = -4142 ' マーカーを削除 ActiveSheet.ChartObjects(1).Chart.SeriesCollection(TMP + z).HasDataLabels = True ' データラベルをONに TARGET = "'" & ActiveSheet.Name & "'!" & adr_ACTIVITY.Offset(z, 8).Address ' 「時間」のセル範囲 .FullSeriesCollection(TMP + z).DataLabels.Select .SeriesCollection(TMP + z).DataLabels.Format.TextFrame2.TextRange. _ InsertChartField msoChartFieldRange, TARGET, 0 ' [activity]データラベルを付与 End With With Selection ' データラベル|位置の調整(右or下) .ShowRange = True .ShowValue = False If adr_ACTIVITY.Offset(z, 4).Value = adr_ACTIVITY.Offset(z, 6).Value Then .Position = xlLabelPositionBelow ' データラベルを不可視マーカーの下に Else .Position = xlLabelPositionRight ' データラベルを不可視マーカーの右に End If End With Next ' その他の系列(ES, LS, TF)を敷設 TMP = 1 + 2 * sumtotal_PREVNODE + 1 ' 系列番号初期値=ノード(1)+アクティビティ2set(x)+1 For x = 0 To 2 For y = 0 To num_ROW - 2 ser_CP = "" ser_CP = adr_TIME.Offset(0, 1 + x).Value & adr_TIME.Offset(1 + y, 0).Value ' 系列名を作成 ser_X = "" ser_X = "'" & ActiveSheet.Name & "'!" & adr_TIME.Offset(1 + y, 4 + 2 * x).Address ' x範囲を作成 ser_Y = "" ser_Y = "'" & ActiveSheet.Name & "'!" & adr_TIME.Offset(1 + y, 5 + 2 * x).Address ' y範囲を作成 With ActiveChart .SeriesCollection.NewSeries .FullSeriesCollection(TMP).Name = ser_CP ' 系列名を付与 .FullSeriesCollection(TMP).XValues = ser_X ' x範囲を指定 .FullSeriesCollection(TMP).Values = ser_Y ' y範囲を指定 .FullSeriesCollection(TMP).Select End With With Selection .MarkerStyle = xlMarkerStyleSquare ' マーカーの形状(四角形) .MarkerSize = 13 ' マーカーの大きさ(pt) .MarkerForegroundColor = RGB(61, 77, 83) ' マーカーの枠線色 .MarkerBackgroundColor = RGB(61, 77, 83) ' マーカーの塗り色 .HasDataLabels = True ' データラベルをONに End With TARGET = "'" & ActiveSheet.Name & "'!" & adr_TIME.Offset(1 + y, 1 + x).Address ' ラベルの内容を範囲指定 With ActiveChart .FullSeriesCollection(TMP).DataLabels.Select .SeriesCollection(TMP).DataLabels.Format.TextFrame2.TextRange. _ InsertChartField msoChartFieldRange, TARGET, 0 End With With Selection .ShowRange = True .ShowValue = False .Position = xlLabelPositionCenter ' データラベルをマーカーの中央に .Format.TextFrame2.TextRange.Font.Size = 8 ' データラベルのフォントサイズ .Format.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255) ' マーカーの色 End With TMP = TMP + 1 Next Next ' OPTION 1 - クリティカルパスの色を変える If OPT1 = True Then Call CriticalPass(num_ROW, sumtotal_PREVNODE, adr_ACTIVITY, adr_TIME) End If ' OPTION 2 - ダミーアクティビティを破線に変える If OPT2 = True Then Call DummyActivity(sumtotal_PREVNODE, adr_ACTIVITY) End If ' OPTION 3 - 作業名を表示する If OPT3 = True Then Call WorkName(num_ROW, sumtotal_PREVNODE, adr_ACTIVITY) End If Application.ScreenUpdating = True End Sub Private Function rowMax() As Long ' [node]下端の行番号を求める rowMax = Range(Range("a1").End(xlDown).Address).Row End Function Private Function colMax(xNum As Long) As Long ' [node]右端の列番号を求める Dim i As Long For i = 3 To xNum If colMax < Cells(i, 1).End(xlToRight).Column Then colMax = Cells(i, 1).End(xlToRight).Column End If Next End Function Private Function preNodes(nR As Long, nC As Long) As Long ' [node]先行ノードの総数を求める preNodes = Application.WorksheetFunction. _ CountA(Range(Cells(3, 4), Cells(nR, nC))) End Function Private Sub CriticalPass(ByVal nR As Long, ByVal sP As Long, ByVal adrACT, ByVal adrTIM) ' OPTION 1 - クリティカルパスの色を変える Dim m As Variant Dim n As Variant Dim ms As Variant Dim ns As Variant Dim mnt As Variant Dim mLS As Variant Dim nLS As Variant Dim TARGET As String Dim TMP As Variant Dim y As Long 'If Application.WorksheetFunction.CountIf(Range(adrTIM.Offset(1, 3), adrTIM.Offset(nR - 1, 3)), "<>0") > 0 Then ' 全TFが0の場合は処理しない TMP = Range(adrTIM.Offset(1, 0), adrTIM.Offset(nR - 1, 3)) For y = 1 To sP m = adrACT.Offset(y, 0).Value ' m n = adrACT.Offset(y, 2).Value ' n ms = Application.WorksheetFunction.VLookup(adrACT.Offset(y, 0).Value, TMP, 4, False) ' mのTF ns = Application.WorksheetFunction.VLookup(adrACT.Offset(y, 2).Value, TMP, 4, False) ' nのTF mnt = adrACT.Offset(y, 8).Value ' m to n のtime Select Case Application.WorksheetFunction.CountIf(Range(adrACT.Offset(1, 2), adrACT.Offset(sP, 2)), n) Case 1 ' 通常処理 If ms = 0 And ns = 0 Then ' "m to n" 両ノードのTFが0であれば TARGET = adrACT.Offset(y, 0).Value &amp "to" &amp adrACT.Offset(y, 2).Value ActiveChart.FullSeriesCollection(TARGET).Select Selection.Format.Line.ForeColor.RGB = RGB(192, 0, 0) ' 系列 "m to n" の線に彩色 End If Case Is >= 2 ' 例外処理(複数の先行アクティビティをもつ場合) mLS = Application.WorksheetFunction.VLookup(adrACT.Offset(y, 0).Value, TMP, 3, False) ' mのLS nLS = Application.WorksheetFunction.VLookup(adrACT.Offset(y, 2).Value, TMP, 3, False) ' nのLS If (ms = 0 And ns = 0) And (nLS - mnt = mLS) Then ' "m to n" 両ノードのTFが0 および 余剰時間が0 であれば TARGET = adrACT.Offset(y, 0).Value &amp "to" &amp adrACT.Offset(y, 2).Value ActiveChart.FullSeriesCollection(TARGET).Select Selection.Format.Line.ForeColor.RGB = RGB(192, 0, 0) ' 系列 "m to n" の線に彩色 End If End Select Next 'End If End Sub Private Sub DummyActivity(ByVal sP As Long, ByVal adrACT) ' OPTION 2 - ダミーアクティビティを破線に変える Dim TARGET As String Dim y As Long For y = 1 To sP Select Case adrACT.Offset(y, 8).Value Case 0 TARGET = adrACT.Offset(y, 0).Value &amp "to" &amp adrACT.Offset(y, 2).Value ActiveChart.FullSeriesCollection(TARGET).Select Selection.Format.Line.DashStyle = msoLineSysDash ' 破線 End Select Next End Sub Private Sub WorkName(ByVal nR As Long, ByVal sP As Long, ByVal adrACT) ' OPTION 3 - 作業名を表示する Dim TARGET As String Dim ser_CP As String Dim ser_X As String Dim ser_Y As String Dim TMP As Variant Dim i As Long Dim x As Long Dim z As Long TMP = 1 + 2 * sP + 3 * (nR - 1) ' 系列番号初期値=ノード(1)+アクティビティ3set(x) i = 0 For z = 1 To sP ser_CP = "" For x = 0 To 2 ser_CP = ser_CP &amp adrACT.Offset(z, x).Value ' 系列名を作成 Next ser_CP = "Caption_" & ser_CP ser_X = "" ser_X = "'" & ActiveSheet.Name & "'!" & adrACT.Offset(z, 9).Address ' x範囲を作成 ser_Y = "" ser_Y = "'" & ActiveSheet.Name & "'!" & adrACT.Offset(z, 10).Address ' y範囲を作成 If adrACT.Offset(z, 7).Value <> "" Then With ActiveChart .SeriesCollection.NewSeries .FullSeriesCollection(TMP + z - i).Name = ser_CP ' 系列名を付与 .FullSeriesCollection(TMP + z - i).XValues = ser_X ' x範囲を指定 .FullSeriesCollection(TMP + z - i).Values = ser_Y ' y範囲を指定 .FullSeriesCollection(TMP + z - i).MarkerStyle = -4142 ' マーカーを削除 End With ActiveSheet.ChartObjects(1).Chart.SeriesCollection(TMP + z - i).HasDataLabels = True ' データラベルをONに TARGET = "'" & ActiveSheet.Name & "'!" & adrACT.Offset(z, 7).Address ' ラベルの内容を範囲指定 With ActiveChart .FullSeriesCollection(TMP + z - i).DataLabels.Select .SeriesCollection(TMP + z - i).DataLabels.Format.TextFrame2.TextRange. _ InsertChartField msoChartFieldRange, TARGET, 0 End With With Selection .ShowRange = True .ShowValue = False .Format.Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground1 ' ラベルの背景色を指定 End With With Selection.Format.Line .Visible = msoTrue .ForeColor.RGB = RGB(176, 188, 195) ' ラベルの枠線色を指定 End With With Selection .Format.TextFrame2.TextRange.Font.Fill.ForeColor.ObjectThemeColor = msoThemeColorText2 ' ラベルの文字色を指定 If adrACT.Offset(z, 4).Value = adrACT.Offset(z, 6).Value Then ' データラベル|位置の調整(下or左) .Position = xlLabelPositionCenter ' 不可視マーカーの下に Else .Position = xlLabelPositionLeft ' 不可視マーカーの左に End If End With Else i = i + 1 ' 作業名の指定がない機会をカウント End If Next End Sub
Step 5マクロの実行(1)―“ARROWDIAGRAM1_preprocess”
Visual Basic Editorを起動させ,標準モジュールを挿入してコードをペーストします。
Visual Basic Editorを閉じ,「マクロ」ダイアログを呼び出して“ARROWDIAGRAM1_preprocess”を選択し実行ボタンをクリックします。
このマクロは,あたらしいシートにいくつかの必要なデータを作成します。
Step 6マクロの実行(2)―“ARROWDIAGRAM2_draw”
あたらしいシートの“Activity”表の「所要時間」を埋めます。エッジ(ノードx to ノードy のアクティビティ)ごとに必要な作業時間をこの列に入力します。ダミーのアクティビティの場合には,“0”を指定します。
デフォルトの値として,「作業名」にはAから始まるアルファベットが順に入ります。これは任意の変更,あるいは削除が可能です(下図ではダミーアクティビティの作業名を削除したうえで,手作業であらためてアルファベットを順に振りなおしています)。
scrollable
上の作業をおえたら,「マクロ」ダイアログから“ARROWDIAGRAM2_draw”を選択し実行ボタンをクリックします。
Step 7書式設定など
いくらかの時間を経て(環境により異なります),下のようなアローダイアグラムが埋め込みの形式で出力されます。
scrollable
凡例・縦横軸・目盛り線を不可視化 あるいは削除する,作業日数・作業名のラベルの位置を調整する,図の大きさを変更する など,任意で書式を設定します。
scrollable
Step 8調整または修正(1)
3つのパラメータ「間隙」「距離」「間隔」の値を増減させることで,下図の対応する彩色部分に関して微調整が可能です。
Step 9調整または修正(2)
ここではノード3および5の位置を最初にアバウトに指定したので,これらをあるべき位置へと修正します。
ドラフトでは,現位置より ノード3は若干左,ノード5は若干右となっています。したがってこれらの元座標を次のように修正します。
Step 10アローダイアグラムの完成
この修正は,アローダイアグラムにそのまま反映されます(作業完了)。
作成にあたり参考にしたWebページ
- プロジェクトマネジメントとはなにか ―"ミームデザイン"(2015.8 閲覧)
- Program Evaluation and Review Technique ―"Wikipedia"(2015.8 閲覧)