BDAstyle

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

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

1.アウトライン

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

[ドラフト※]

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

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

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

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

また クリティカル パス・ダミー アクティビティ・作業名 の描画はデフォルトでONですが,これらの機能はコードから当該部分を直接削除することで排除可能です。

仕様

免責および特記事項

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)―コードのコピー

次のコードをすべて選択し,コピーします。

Sub ARROWDIAGRAM1_preprocess()

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

On Error GoTo myError

Dim num_ROW As Long ' 下端行番号
Dim num_COL As Long ' 右端列番号
Dim sumtotal_PREVNODE As Long ' 先行ノード総数
Dim adr_DATATABLE As 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

TMP = ActiveSheet.Name ' シートのコピー
Worksheets(TMP).Copy after:=Worksheets(TMP)

num_COL = 0
num_ROW = 0

num_ROW = Range(Range("a1").End(xlDown).Address).Row ' 下端行番号
For y = 3 To num_ROW ' 右端列番号
    If num_COL < Cells(y, 1).End(xlToRight).Column Then
        num_COL = Cells(y, 1).End(xlToRight).Column
    End If
Next

sumtotal_PREVNODE = Application.WorksheetFunction. _
    CountA(Range(Cells(3, 4), Cells(num_ROW, num_COL))) ' 先行ノード数

Set adr_DATATABLE = Cells(1, 1) ' [初期データ]表 左上端セルアドレス
Set adr_ACTIVITY = adr_DATATABLE.Offset(0, num_COL + 1) ' [アクティビティ] 左上端セルアドレス
Set adr_PARAM = adr_ACTIVITY.Offset(0, 12) ' [表示位置調整値] 左上端セルアドレス
Set adr_TIME = adr_PARAM.Offset(0, 2) ' [時間] 左上端セルアドレス

With adr_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 ' [表示位置調整値]表見出し
    .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 ' [時間]表見出し
    .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 ' [アクティビティ]表
    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 ' [時間]表 ノード番号転記
    adr_TIME.Offset(y, 0).Value = adr_DATATABLE.Offset(y, 0).Value
Next

Exit Sub

myError:
   MsgBox "実行時エラーが発生しました。処理を終了します。"

End Sub

Sub ARROWDIAGRAM2_draw()

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

On Error GoTo myError

Dim num_ROW As Long ' 下端行番号
Dim num_COL As Long ' 右端列番号
Dim sumtotal_PREVNODE As Long ' 先行ノード総数
Dim adr_DATATABLE As 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

num_COL = 0
num_ROW = 0

num_ROW = Range(Range("a1").End(xlDown).Address).Row ' 下端行番号

For y = 3 To num_ROW ' 右端列番号
    If num_COL < Cells(y, 1).End(xlToRight).Column Then
        num_COL = Cells(y, 1).End(xlToRight).Column
    End If
Next

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
    lt2num_NODE(z, 1) = z
Next

sumtotal_PREVNODE = Application.WorksheetFunction.CountA(Range(Cells(3, 4), Cells(num_ROW, num_COL))) ' 先行ノード総数
ReDim BUF(sumtotal_PREVNODE - 2)

Set adr_DATATABLE = Cells(1, 1) ' [初期データ]表 左上端セルアドレス
Set adr_ACTIVITY = adr_DATATABLE.Offset(0, num_COL + 1) ' [アクティビティ]表 左上端セルアドレス
Set adr_PARAM = adr_ACTIVITY.Offset(0, 12) ' [表示位置調整値] 左上端セルアドレス
Set adr_TIME = adr_PARAM.Offset(0, 2) ' [時間] 左上端セルアドレス

' 最早開始時刻(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 ' LabEAR_x
        .Offset(y, 5).Formula = "=" & adr_DATATABLE.Offset(y, 2).Address & "+" & adr_PARAM.Offset(4, 0).Address ' LabEAR_y
    
        .Offset(y, 6).Formula = "=" & .Offset(y, 4).Address & "+" & adr_PARAM.Offset(7, 0).Address ' LabLAT_x
        .Offset(y, 7).Formula = "=" & .Offset(y, 5).Address ' LabLAT_y
    
        .Offset(y, 8).Formula = "=" & .Offset(y, 6).Address & "+" & adr_PARAM.Offset(7, 0).Address ' LabFLT_x
        .Offset(y, 9).Formula = "=" & .Offset(y, 7).Address ' LabFLT_y
    End With
Next

' 以下グラフ描画
' [ノード]系列の作成
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
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
End With
With Selection
    .ShowRange = True
    .ShowValue = False
    .Position = xlLabelPositionCenter ' データラベルをノードの中央に
End With
       
' [アクティビティ]系列の作成
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 = "" ' X範囲の作成
    ser_X = "'" & ActiveSheet.Name & "'!" & adr_ACTIVITY.Offset(z, 3).Address & _
                ",'" & ActiveSheet.Name & "'!" & adr_ACTIVITY.Offset(z, 5).Address
        
    ser_Y = "" ' Y範囲の作成
    ser_Y = "'" & ActiveSheet.Name & "'!" & adr_ACTIVITY.Offset(z, 4).Address & _
                ",'" & ActiveSheet.Name & "'!" & adr_ACTIVITY.Offset(z, 6).Address

    With ActiveChart
        .SeriesCollection.NewSeries
        .FullSeriesCollection(z + 1).Name = ser_CP
        .FullSeriesCollection(z + 1).XValues = ser_X
        .FullSeriesCollection(z + 1).Values = ser_Y
        .FullSeriesCollection(z + 1).Select
    End With
    With Selection
        .Format.Line.Visible = msoTrue
        .Format.Line.EndArrowheadStyle = msoArrowheadTriangle
        .MarkerStyle = -4142
    End With
Next
 
' [時間]系列の作成
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 = "Time_" & ser_CP
    ser_X = "" ' X範囲の作成
    ser_X = "'" & ActiveSheet.Name & "'!" & adr_ACTIVITY.Offset(z, 9).Address
    ser_Y = "" ' Y範囲の作成
    ser_Y = "'" & ActiveSheet.Name & "'!" & adr_ACTIVITY.Offset(z, 10).Address
      
    With ActiveChart
        .SeriesCollection.NewSeries
        .FullSeriesCollection(TMP + z).Name = ser_CP
        .FullSeriesCollection(TMP + z).XValues = ser_X
        .FullSeriesCollection(TMP + z).Values = ser_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
    End With
    With Selection
        .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
  
' [情報]系列の作成
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 = "" ' X範囲の作成
        ser_X = "'" & ActiveSheet.Name & "'!" & adr_TIME.Offset(1 + y, 4 + 2 * x).Address
        ser_Y = "" ' Y範囲の作成
        ser_Y = "'" & ActiveSheet.Name & "'!" & adr_TIME.Offset(1 + y, 5 + 2 * x).Address
          
        With ActiveChart
            .SeriesCollection.NewSeries
            .FullSeriesCollection(TMP).Name = ser_CP
            .FullSeriesCollection(TMP).XValues = ser_X
            .FullSeriesCollection(TMP).Values = ser_Y
            .FullSeriesCollection(TMP).Select
        End With
        
        With Selection
            .MarkerStyle = xlMarkerStyleCircle ' マーカーの形状(円)
            .MarkerSize = 12
            .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 - クリティカルパス色変更 ■■■■■
Dim ms As Variant
Dim ns As Variant
Dim mnt As Variant
Dim mLS As Variant
Dim nLS As Variant

If Application.WorksheetFunction.CountIf(Range(adr_TIME.Offset(1, 3), adr_TIME.Offset(num_ROW - 1, 3)), "<>0") > 0 Then
    TMP = Range(adr_TIME.Offset(1, 0), adr_TIME.Offset(num_ROW - 1, 3)) ' 全slackが0の場合は処理しない

    For y = 1 To sumtotal_PREVNODE
        m = adr_ACTIVITY.Offset(y, 0).Value ' m
        n = adr_ACTIVITY.Offset(y, 2).Value ' n
        ms = Application.WorksheetFunction.VLookup(adr_ACTIVITY.Offset(y, 0).Value, TMP, 4, False) ' mのSlack
        ns = Application.WorksheetFunction.VLookup(adr_ACTIVITY.Offset(y, 2).Value, TMP, 4, False) ' nのSlack
        mnt = adr_ACTIVITY.Offset(y, 8).Value ' m to n のtime
            
        Select Case Application.WorksheetFunction.CountIf(Range(adr_ACTIVITY.Offset(1, 2), adr_ACTIVITY.Offset(sumtotal_PREVNODE, 2)), n)
        Case 1 ' 通常処理
            If ms = 0 And ns = 0 Then  ' "m to n" 両ノードのslackが0であれば
                TARGET = adr_ACTIVITY.Offset(y, 0).Value & "to" & adr_ACTIVITY.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(adr_ACTIVITY.Offset(y, 0).Value, TMP, 3, False) ' mのLS
            nLS = Application.WorksheetFunction.VLookup(adr_ACTIVITY.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 = adr_ACTIVITY.Offset(y, 0).Value & "to" & adr_ACTIVITY.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

' ■■■■■ OPTION 2 - ダミーアクティビティ破線変更 ■■■■■
For y = 1 To sumtotal_PREVNODE
    Select Case adr_ACTIVITY.Offset(y, 8).Value
    Case 0
        TARGET = adr_ACTIVITY.Offset(y, 0).Value & "to" & adr_ACTIVITY.Offset(y, 2).Value
        ActiveChart.FullSeriesCollection(TARGET).Select
        Selection.Format.Line.DashStyle = msoLineSysDash
    End Select
Next

' ■■■■■ OPTION 3 - 作業名の表示 ■■■■■
TMP = 1 + 2 * sumtotal_PREVNODE + 3 * (num_ROW - 1) ' 系列番号初期値=ノード(1)+アクティビティ3set(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 = "Caption_" & ser_CP
    ser_X = "" ' X範囲の作成
    ser_X = "'" & ActiveSheet.Name & "'!" & adr_ACTIVITY.Offset(z, 9).Address
    ser_Y = "" ' Y範囲の作成
    ser_Y = "'" & ActiveSheet.Name & "'!" & adr_ACTIVITY.Offset(z, 10).Address
      
With ActiveChart
    .SeriesCollection.NewSeries
    .FullSeriesCollection(TMP + z).Name = ser_CP
    .FullSeriesCollection(TMP + z).XValues = ser_X
    .FullSeriesCollection(TMP + z).Values = ser_Y
    .FullSeriesCollection(TMP + z).MarkerStyle = -4142 ' マーカー「なし」
End With

    ActiveSheet.ChartObjects(1).Chart.SeriesCollection(TMP + z).HasDataLabels = True ' データラベルON
        
    TARGET = "'" & ActiveSheet.Name & "'!" & adr_ACTIVITY.Offset(z, 7).Address ' データラベル・表示範囲
    With ActiveChart
        .FullSeriesCollection(TMP + z).DataLabels.Select
        .SeriesCollection(TMP + z).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 adr_ACTIVITY.Offset(z, 4).Value = adr_ACTIVITY.Offset(z, 6).Value Then
            .Position = xlLabelPositionCenter ' データラベルを不可視マーカーの下に
        Else
            .Position = xlLabelPositionLeft ' データラベルを不可視マーカーの右に
        End If
    End With
Next
   
Exit Sub

myError:
   MsgBox "実行時エラーが発生しました。処理を終了します。"

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”を指定します。

またデフォルトの「作業名」は任意に変更可能です。

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

Step 7書式設定など

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

凡例・縦横軸・目盛り線を不可視化 あるいは削除する,作業日数・作業名のラベルの位置を調整する,図の大きさを変更する など,任意に書式設定をおこないます(ここでの例示のように「作業名」列に空白のある場合,当該作業に関してラベルの枠だけが表示されます。この場合,目的のラベルの線色・塗り色を「なし」にすれば不可視にできます)。

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

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

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

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

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

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

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

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

その他の参照