マクロでエクセルに表示される座標を基準に矢印を引く

質問

ガントチャートをエクセルで作成しているのですが、
それぞれのタスクの関係性がわかるよう、
関係元タスクの終点と、関係先タスクの始点を矢印で結びたいと思っています。
タスクリンクの始点終点に入力された数字を参照して、同じ数字の組み合わせを見つけ出し、
右側に関数で表示されている座標数値を参照させて矢印を引きたいと考えています。
※座標数値はタスクの終了日を変更などで変動し、
　またガントチャート側の表示基準日を変更することで参照するべきセルが消失し、座標表示が空欄になることもあります。
例）タスクリンク３番の場合、
cell(10,31)からcell(12,38)へ
cell(11,38)からcell(12,38)へ
　　2つの矢印が引かれることを想定しています。

以下のように座標を数字指定して矢印を挿入するマクロまでは作れたのですが、
共通するタスクリンク番号を抽出し、それぞれの座標数のあてはめ、矢印の作成を最大タスクリンク番号まで引くようなマクロにしたいです。
よろしくお願いいたします。

Sub タスクリンク()
Dim endX As Single, endY As Single, startX As Single, startY As Single
With Cells(10, 31)
endX = .Left + .Width / 2
endY = .Top + .Height / 2
End With
With Cells(12, 38)
startX = .Left + .Width / 2
startY = .Top + .Height / 2
End With
With ActiveSheet.Shapes.AddConnector(msoConnectorElbow, endX, endY, startX, startY).Line
.EndArrowheadStyle = msoArrowheadTriangle
.ForeColor.RGB = RGB(255, 0, 0)
.DashStyle = msoLineRoundDot
.Weight = 3
End With
End Sub

回答No.2

HohoPapa · ベストアンサー

最初に添付された画像に列番号、行番号、シートタブがなく
その後、https://imgur.com/a/3kCnNyl　にポストされた画像に
シートタブがないので、私からの返答にぶれが起きています。

先に示したコードは、
課題のシートがブックの1枚目にあることが前提です。
もし、
選択した（アクティブな）シートでの実行を望まれるのであれば
以下のコードを試してみてください。
当方では、動作しています。

また、作成されだろう図形の数を最大100と想定しました。
異なるようであれば想定数を教えてください。

Sub sample()

Const ColST = 11 'タスクリンク始点列
Const ColET = 12 'タスクリンク終点列
Const ColSY = 13 '始点座標行の列
Const ColSX = 14 '始点座標列の列
Const ColEY = 15 '終点座標行の列
Const ColEX = 16 '終点座標列の列
Const STRow = 8 '座標データ開始行

Dim endX As Single, endY As Single, startX As Single, startY As Single

Dim i As Long
Dim j As Long
Dim TNum As Long
Dim shp As Shape
Dim ZuNum As Long

With ThisWorkbook.ActiveSheet

'接続図を全数削除（最大百個）
For i = 1 To 100
On Error Resume Next
Set shp = .Shapes("MyShp" & Format(i, "000"))
shp.Delete
On Error GoTo 0
Next i

i = STRow
ZuNum = 0
Do
If ((.Cells(i, ColST).Value = "") And _
(.Cells(i, ColET).Value = "")) Then Exit Do
TNum = .Cells(i, ColST).Value
j = STRow
Do
If .Cells(j, ColET).Value = "" Then Exit Do
If .Cells(j, ColET).Value = TNum Then
If ( _
(.Cells(i, ColSY).Value <> "") And _
(.Cells(i, ColSX).Value <> "") And _
(.Cells(j, ColEY).Value <> "") And _
(.Cells(j, ColEX).Value <> "")) Then
ZuNum = ZuNum + 1
With .Cells(.Cells(j, ColEY).Value, .Cells(j, ColEX).Value)
endX = .Left + .Width / 2
endY = .Top + .Height / 2
End With
With .Cells(.Cells(i, ColSY).Value, .Cells(i, ColSX).Value)
startX = .Left + .Width / 2
startY = .Top + .Height / 2
End With

Set shp = .Shapes.AddConnector(msoConnectorElbow, endX, endY, startX, startY)
With shp
.Name = "MyShp" & Format(ZuNum, "000")
.Line.EndArrowheadStyle = msoArrowheadTriangle
.Line.ForeColor.RGB = RGB(255, 0, 0)
.Line.DashStyle = msoLineRoundDot
.Line.Weight = 3
End With
End If
End If
j = j + 1
Loop
i = i + 1
Loop

End With

End Sub

お礼

HohoPapa様
回答2番に対する補足質問ですが、
タスク名を記載する列が空白ならばexit doすると記述することで、自己解決できました。
ありがとうございました！

補足

HohoPapa様
確かにシート名の部分を失念していました。
シート名を固定することで動作が確認できました。
あと1点だけよろしいでしょうか。

追加画像
https://imgur.com/a/WoRfNsa
このように前工程、次工程に関係ないタスクがあった場合、

Do
If ((.Cells(i, ColST).Value = "") And _
(.Cells(i, ColET).Value = "")) Then Exit Do

の部分が引っかかって矢印が引かれなくなります。
最後の行でループを終了させたい意図はわかるのですが、
タスクリンクが入力されている最後の行(i)を取得して～
みたいなことはできないものでしょうか。

いろいろお願いして恐縮ですが
おねがいいたします。

回答No.1

HohoPapa

お求めの仕様を理解しきれているか若干不安ですが
以下のコードでいかがでしょうか。

Option Explicit

Sub sample()

　Const ColST = 4 'タスクリンク始点の埋まった列番号
　Const ColET = 5 'タスクリンク終点の埋まった列番号
　Const ColSY = 6 '始点座標行の埋まった列番号
　Const ColSX = 7 '始点座標列の埋まった列番号
　Const ColEY = 8 '終点座標行の埋まった列番号
　Const ColEX = 9 '終点座標列の埋まった列番号
　Const STRow = 4 '座標データ開始行

　Dim endX As Single, endY As Single, startX As Single, startY As Single

　Dim i As Long
　Dim j As Long
　Dim TNum As Long
　Dim shp As Shape
　Dim ZuNum As Long

　With ThisWorkbook.Sheets(1)

　　'接続図を全数削除（最大百個）
　　For i = 1 To 100
　　　On Error Resume Next
　　　Set shp = .Shapes("MyShp" & Format(i, "000"))
　　　shp.Delete
　　　On Error GoTo 0
　　Next i

　　i = STRow
　　ZuNum = 0
　　Do
　　　If ((.Cells(i, ColST).Value = "") And _
　　　　　(.Cells(i, ColET).Value = "")) Then Exit Do
　　　TNum = .Cells(i, ColST).Value
　　　j = STRow
　　　Do
　　　　If .Cells(j, ColET).Value = "" Then Exit Do
　　　　If .Cells(j, ColET).Value = TNum Then
　　　　　If ( _
　　　　　　(.Cells(i, ColSY).Value <> "") And _
　　　　　　(.Cells(i, ColSX).Value <> "") And _
　　　　　　(.Cells(j, ColEY).Value <> "") And _
　　　　　　(.Cells(j, ColEX).Value <> "")) Then
　　　　　　ZuNum = ZuNum + 1
　　　　　　With .Cells(.Cells(j, ColEY).Value, .Cells(j, ColEX).Value)
　　　　　　　endX = .Left + .Width / 2
　　　　　　　endY = .Top + .Height / 2
　　　　　　End With
　　　　　　With .Cells(.Cells(i, ColSY).Value, .Cells(i, ColSX).Value)
　　　　　　　startX = .Left + .Width / 2
　　　　　　　startY = .Top + .Height / 2
　　　　　　End With

　　　　　　Set shp = .Shapes.AddConnector(msoConnectorElbow, endX, endY, startX, startY)
　　　　　　With shp
　　　　　　　.Name = "MyShp" & Format(ZuNum, "000")
　　　　　　　.Line.EndArrowheadStyle = msoArrowheadTriangle
　　　　　　　.Line.ForeColor.RGB = RGB(255, 0, 0)
　　　　　　　.Line.DashStyle = msoLineRoundDot
　　　　　　　.Line.Weight = 3
　　　　　　End With
　　　　　End If
　　　　End If
　　　　j = j + 1
　　　Loop
　　　i = i + 1
　　Loop

　End With

End Sub

補足

HohoPapa 様　ありがとうございます。
新規でxlsmを作成してマクロを動かしたところ、
私が希望していた動きでした。
ですが、私が現在作成しているGC用に数字を書き換えていくと、何も作成されない状況です。

追加画像
https://imgur.com/a/3kCnNyl

上記画像の環境の場合、
Const ColST = 11 'タスクリンク始点の埋まった列番号
Const ColET = 12 'タスクリンク終点の埋まった列番号
Const ColSY = 13 '始点座標行の埋まった列番号
Const ColSX = 14 '始点座標列の埋まった列番号
Const ColEY = 15 '終点座標行の埋まった列番号
Const ColEX = 16 '終点座標列の埋まった列番号
Const STRow = 8'座標データ開始行

以下書き換え無し

このような認識でいるのですが、何が違いそうでしょうか。
追加質問で申し訳ないのですがよろしくお願いいたします。