BDAstyle

ビジネスデータ分析ツールの作成 with Excel

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

1.アウトライン

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

[ドラフト※]

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

[Excel によるアウトプット]

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

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

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

仕様

免責および特記事項

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

Step 1元表の作成(1)―ノードの定義

次のような見出しをA1のセルから用意します。

見出し「ノード」の下には,利用するノード番号(1, 2, 3,...など)ないしは記号(A, B, C,...など)を入力しておきます。

Step 2元表の作成(2)―ノード座標の作成

ノードの位置を目安にして ドラフトにグリッドを作成し,

縦横のグリッド線に番号を付加します。横軸の番号は最も左の線を1,縦軸の番号は(見た目上)軸となる線を0として番号を振っていくと簡単です。

すべてのノードの位置を直交座標によりシート上に示します。細かな調整はあとからでも可能なので,この時点ではアバウトでOKです。

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()

' *** アローダイアグラムの作成|前処理 ver.1.1
' *** http://bdastyle.net/tools/project-management/arrow-diagram.html ―"BDAstyle"
' *** 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 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_ACTIVITY = adr_DATATABLE.Offset(0, num_COL + 1) ' [activity]表の基点を格納
Set adr_PARAM = adr_ACTIVITY.Offset(0, 12) ' [adjust]表の基点を格納
Set adr_TIME = adr_PARAM.Offset(0, 2) ' [time]表の基点を格納

With adr_ACTIVITY ' [activity]表の見出しを設置
    .Offset(0, 0).Value = "Activity"
    .Offset(0, 3).Value = "SP_x"
    .Offset(0, 4).Value = "SP_y"
    .Offset(0, 5).Value = "EP_x"
    .Offset(0, 6).Value = "EP_y"
    .Offset(0, 7).Value = "作業名"
    .Offset(0, 8).Value = "時間"
    .Offset(0, 9).Value = "T_x"
    .Offset(0, 10).Value = "T_y"
End With
    
With adr_PARAM ' [adjust]表の見出しと初期値を設置
    .Offset(0, 0).Value = "A_長さ調整"
    .Offset(1, 0).Value = 0.21
    .Offset(3, 0).Value = "T_距離調整"
    .Offset(4, 0).Value = 0.25
    .Offset(6, 0).Value = "T_間隔調整"
    .Offset(7, 0).Value = 0.2
End With
        
With adr_TIME ' [time]表見出しを設置
    .Offset(0, 0).Value = "Node"
    .Offset(0, 1).Value = "ES"
    .Offset(0, 2).Value = "LS"
    .Offset(0, 3).Value = "Slack"
    .Offset(0, 4).Value = "LabES_x"
    .Offset(0, 5).Value = "LabES_y"
    .Offset(0, 6).Value = "LabLS_x"
    .Offset(0, 7).Value = "LabLS_y"
    .Offset(0, 8).Value = "LabSlack_x"
    .Offset(0, 9).Value = "LabSlack_y"
End With

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
    For y = 1 To sumtotal_PREVNODE ' エッジ(矢印)の始点と終点を求め,その他項目を設置する
        .Offset(y, 3).Formula = "=vlookup(" & .Offset(y, 0).Address & "," & TARGET & ",2,false)" ' SP_x
        .Offset(y, 4).Formula = "=vlookup(" & .Offset(y, 0).Address & "," & TARGET & ",3,false)" ' SP_y
        .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))" ' EP_x
        .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))" ' EP_y
        .Offset(y, 7).Formula = "=""Work "" & row()-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))" ' T_x
        .Offset(y, 10).Formula = "=average(" & .Offset(y, 4).Address & _
            "," & .Offset(y, 6).Address & ")" ' T_y
    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()

' *** アローダイアグラムの作成|主処理 ver.1.1
' *** http://bdastyle.net/tools/project-management/arrow-diagram.html ―"BDAstyle"

' *** 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_ACTIVITY = adr_DATATABLE.Offset(0, num_COL + 1) ' [activity]表の基点を格納
Set adr_PARAM = adr_ACTIVITY.Offset(0, 12) ' [adjust]表の基点を格納
Set adr_TIME = adr_PARAM.Offset(0, 2) ' [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

' Slackを計算
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 ' LabES_x
        .Offset(y, 5).Formula = "=" & adr_DATATABLE.Offset(y, 2).Address & "+" & adr_PARAM.Offset(4, 0).Address ' LabES_y
    
        .Offset(y, 6).Formula = "=" & .Offset(y, 4).Address & "+" & adr_PARAM.Offset(7, 0).Address ' LabLS_x
        .Offset(y, 7).Formula = "=" & .Offset(y, 5).Address ' LabLS_y
    
        .Offset(y, 8).Formula = "=" & .Offset(y, 6).Address & "+" & adr_PARAM.Offset(7, 0).Address ' LabSlack_x
        .Offset(y, 9).Formula = "=" & .Offset(y, 7).Address ' LabSlack_y
    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, Slack)を敷設
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 = xlMarkerStyleCircle ' マーカーの形状(円)
            .MarkerSize = 12 ' マーカーの大きさ(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
    TMP = Range(adrTIM.Offset(1, 0), adrTIM.Offset(nR - 1, 3)) ' 全slackが0の場合は処理しない

    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のSlack
        ns = Application.WorksheetFunction.VLookup(adrACT.Offset(y, 2).Value, TMP, 4, False) ' nのSlack
        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" 両ノードのslackが0であれば
                TARGET = adrACT.Offset(y, 0).Value & "to" & 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" 両ノードのslackが0 および 余剰時間が0 であれば
                TARGET = adrACT.Offset(y, 0).Value & "to" & 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 & "to" & 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 & 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”を指定します。

デフォルトでは,「作業名」には「Work」の1から始まる呼称が順に入ります。これは下のように任意の変更あるいは削除が可能です。

scrollable

上の作業をおえたら,「マクロ」ダイアログから“ARROWDIAGRAM2_draw”を選択し実行ボタンをクリックします。

Step 7書式設定など

いくらかの時間を経て(環境により異なります),下のようなアローダイアグラムが埋め込みの形式で出力されます。

scrollable

凡例・縦横軸・目盛り線を不可視化 あるいは削除する,作業日数・作業名のラベルの位置を調整する,図の大きさを変更する など,任意で書式を設定します。

scrollable

Step 8調整または修正(1)

3つのパラメータ「A_長さ調整」「T_距離調整」「T_間隔調整」の値を増減させることで,下図の対応する彩色部分に関して微調整が可能です。

Step 9調整または修正(2)

ここではノード3および5の位置を最初にアバウトに指定したので,これらをあるべき位置へと修正します。

ドラフトでは,現位置より ノード3は若干左,ノード5は若干右となっています。したがってこれらの元座標を次のように修正します。

Step 10アローダイアグラムの完成

この修正は,アローダイアグラムにそのまま反映されます(作業完了)。

作成にあたり参考にしたWebサイト

その他の参照