BDAstyle

Business Data Analysis & Visualization with Excel

アローダイアグラムの作成 with Excel VBA(ver.2013 or later)

アウトライン

アローダイアグラム(PERT図)の手描きのドラフトをもとに，Excelでアローダイアグラムを作成します。

［ドラフト※］

※［PDF］基本情報技術者試験(平成22年度秋期試験)午前・問52 を引用して作成

［Excel によるアウトプット］

このアウトプットには，矢印をアクティビティとする形式を用います(Activity on Arrow)。

描画に際し，ノードごとに最早開始時刻(ES)・最遅開始時刻(LS)・余裕時間(TF)を求めこれらをあわせて表示します。

また ｜クリティカルパス｜ダミーアクティビティ｜作業名｜ の描画はデフォルトでONですが，これらの機能はコード先頭の定数部分をFALSEに変えることで排除することが可能です。

仕様

免責および特記事項

アローダイアグラムの作成

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ページ

その他の参照