入力された日付に対応する位置に矢印を配置したい

質問

画像のようなカレンダーを使用しています。
1月1日～12月31日まで横に続いています。

予定日の開始と終了のセルに入力された日付をカレンダー部分の対応する日付にオートシェイプの矢印をセル上部に配置
同じように実行日の開始と終了のセルに入力された日付を対応する日付にオートシェイプの矢印をセル下部に配置する処理がしたいです
画像は参考程度に手動で配置した状態です。

ガントチャートで検索すると様々なやり方が公開されていますが、どれもカレンダーの書式が違ったりと参考にするには難しかったです

多少プログラミングの経験はあるのですが、公開されているコードを見てもいまいちわかりませんでした。

どなたかご教示願います

回答No.5

HohoPapa · ベストアンサー

>予定日にしか日付が入力されていない場合は赤の矢印だけ配置することは可能でしょうか...？
配置しないという制御の場合、
後からその箇所に配置することになった場合の制御が面倒なので、
開始、終了の日付の一方でも埋まっていない場合は
矢印の変更を行わないようにしました。
（矢印が見えないままなので、見掛け上配置しない場合と同等です）

加えて、
・既に削除されているなど、削除できない場合にはスルーするように。
・実線／破線の指定を加え
・太さの指定を加え
・参考にしたurlを貼っておきました。

Sub sample1()　'図形を初期配置
　Dim RowCnt As Long
　Dim tgSh As Worksheet
　Set tgSh = ThisWorkbook.Sheets(1)
　RowCnt = 4
　Do
　　If tgSh.Cells(RowCnt, 1).Value = "" Then Exit Do
　　MakeArrow tgSh, RowCnt, 8, 1
　　MakeArrow tgSh, RowCnt, 8, 2
　　RowCnt = RowCnt + 1
　Loop
End Sub

Sub sample2()　'図形を全数削除
　Dim RowCnt As Long
　Dim tgSh As Worksheet
　Set tgSh = ThisWorkbook.Sheets(1)
　RowCnt = 4
　Do
　　If tgSh.Cells(RowCnt, 1).Value = "" Then Exit Do
　　DelArrow tgSh, RowCnt, 1
　　DelArrow tgSh, RowCnt, 2
　　RowCnt = RowCnt + 1
　Loop
End Sub

Sub sample3()　'図形の表示開始位置、表示最終位置を変更
　Dim RowCnt As Long
　Dim tgSh As Worksheet
　Dim SCol1 As Long
　Dim ECol1 As Long
　Dim SCol2 As Long
　Dim ECol2 As Long

　Set tgSh = ThisWorkbook.Sheets(1)
　RowCnt = 4

　Do
　　If tgSh.Cells(RowCnt, 1).Value = "" Then Exit Do
　　With tgSh
　　　If IsDate(.Cells(RowCnt, 1).Value) And _
　　　　　IsDate(.Cells(RowCnt, 2).Value) Then
　　　　SCol1 = tgSh.Cells(RowCnt, 1).Value - DateSerial(2019, 12, 31) + 8
　　　　ECol1 = tgSh.Cells(RowCnt, 2).Value - DateSerial(2019, 12, 31) + 9
　　　　EditArrow tgSh, RowCnt, SCol1, ECol1, 1
　　　End If
　　　If IsDate(.Cells(RowCnt, 6).Value) And _
　　　　　IsDate(.Cells(RowCnt, 7).Value) Then
　　　　SCol2 = tgSh.Cells(RowCnt, 6).Value - DateSerial(2019, 12, 31) + 8
　　　　ECol2 = tgSh.Cells(RowCnt, 7).Value - DateSerial(2019, 12, 31) + 9
　　　　EditArrow tgSh, RowCnt, SCol2, ECol2, 2
　　　End If
　　　RowCnt = RowCnt + 1
　　End With
　Loop

End Sub

'//================================初期表示
'//　プロパティ一覧　http://officetanaka.net/excel/vba/tips/tips177.htm
Sub MakeArrow(Sh As Worksheet, SRow As Long, Scol As Long, MyPosCode As Long)
　'MyPosCode 表示位置（上下）1:上から1/3　2:上から2/3
　Dim MyPos As Double
　Dim ArrowName As String
　ArrowName = "Zu" & Format(SRow, "0000") & Format(MyPosCode, "0")
　If MyPosCode = 1 Then
　　MyPos = Sh.Cells(SRow, Scol).Height / 3
　Else
　　MyPos = Sh.Cells(SRow, Scol).Height / 3 * 2
　End If
　With Sh.Shapes.AddConnector( _
　　Type:=msoConnectorStraight, _
　　BeginX:=Range(Sh.Cells(SRow, Scol), Sh.Cells(SRow, Scol)).Left, _
　　Beginy:=Range(Sh.Cells(SRow, Scol), Sh.Cells(SRow, Scol)).Top + MyPos, _
　　EndX:=Range(Sh.Cells(SRow, Scol + 1), Sh.Cells(SRow, Scol + 1)).Left, _
　　EndY:=Range(Sh.Cells(SRow, Scol), Sh.Cells(SRow, Scol)).Top + MyPos)
　 .Line.EndArrowheadStyle = msoArrowheadStealth
　 .Name = ArrowName
　 .Line.Weight = 2　　'太さ
　 '.Line.DashStyle = msoLineSysDot　　'破線
　 .Line.DashStyle = msoLineSolid　　'実線
　 If MyPosCode = 1 Then
　　 .Line.ForeColor.RGB = RGB(255, 0, 0) '赤
　 Else
　　 .Line.ForeColor.RGB = RGB(0, 0, 255) '青
　 End If

　End With
　'Sh.Shapes.Range(Array(ArrowName)).Visible = False　 '※本番用
　Sh.Shapes.Range(Array(ArrowName)).Visible = True　　'※デバック用
End Sub

'//================================削除
Sub DelArrow(Sh As Worksheet, SRow As Long, MyPosCode As Long)
　Dim ArrowName As String
　On Error Resume Next
　ArrowName = "Zu" & Format(SRow, "0000") & Format(MyPosCode, "0")
　Sh.Shapes.Range(Array(ArrowName)).Delete
End Sub

'//================================開始位置、終了位置を変更して表示する
Sub EditArrow(Sh As Worksheet, SRow As Long, Scol As Long, ECol As Long, MyPosCode As Long)
　Dim MyPos As Double
　Dim ArrowName As String
　On Error Resume Next
　ArrowName = "Zu" & Format(SRow, "0000") & Format(MyPosCode, "0")
　Sh.Shapes(ArrowName).Left = _
　　Range(Sh.Cells(SRow, Scol), Sh.Cells(SRow, Scol)).Left
　Sh.Shapes(ArrowName).Width = _
　　Range(Sh.Cells(SRow, ECol), Sh.Cells(SRow, ECol)).Left - _
　　Range(Sh.Cells(SRow, Scol), Sh.Cells(SRow, Scol)).Left
　Sh.Shapes.Range(Array(ArrowName)).Visible = True
End Sub

回答No.4

HohoPapa

更にごめんなさい。
上側と下側の矢印の色を変えるんですね。
Sub MakeArrow(....　を
以下に差し替えてください。

'//================================初期表示
Sub MakeArrow(Sh As Worksheet, SRow As Long, Scol As Long, MyPosCode As Long)
　'MyPosCode 表示位置（上下）1:上から1/3　2:上から2/3
　Dim MyPos As Double
　Dim ArrowName As String
　ArrowName = "Zu" & Format(SRow, "0000") & Format(MyPosCode, "0")
　If MyPosCode = 1 Then
　　MyPos = Sh.Cells(SRow, Scol).Height / 3
　Else
　　MyPos = Sh.Cells(SRow, Scol).Height / 3 * 2
　End If
　With Sh.Shapes.AddConnector( _
　　Type:=msoConnectorStraight, _
　　BeginX:=Range(Sh.Cells(SRow, Scol), Sh.Cells(SRow, Scol)).Left, _
　　Beginy:=Range(Sh.Cells(SRow, Scol), Sh.Cells(SRow, Scol)).Top + MyPos, _
　　EndX:=Range(Sh.Cells(SRow, Scol + 1), Sh.Cells(SRow, Scol + 1)).Left, _
　　EndY:=Range(Sh.Cells(SRow, Scol), Sh.Cells(SRow, Scol)).Top + MyPos)
　 .Line.EndArrowheadStyle = msoArrowheadStealth
　 .Name = ArrowName

　 If MyPosCode = 1 Then
　　 .Line.ForeColor.RGB = RGB(255, 0, 0) '赤
　 Else
　　 .Line.ForeColor.RGB = RGB(0, 0, 255) '青
　 End If

　End With
　'Sh.Shapes.Range(Array(ArrowName)).Visible = False　 '※本番用
　Sh.Shapes.Range(Array(ArrowName)).Visible = True　　'※デバック用
End Sub

補足

>HohoPapaさん
とても丁寧にありがとうございます...!
こちらの環境でもプログラムを実行することができました。

ただ、予定日には日付が入力されていて実行日に日付が入力されていないセルがある場合、プログラムの実行が停止してしまいます。
予定日にしか日付が入力されていない場合は赤の矢印だけ配置することは可能でしょうか...？
はじめにこのような場合もあることを記載しておくべきでした、申し訳有りません。

回答No.3

HohoPapa

#2です。
>1月1日～12月31日まで横に続いています。
これを見落としていましたので差し替えます。

Sub sample1()　'図形を初期配置
　Dim RowCnt As Long
　Dim tgSh As Worksheet
　Set tgSh = ThisWorkbook.Sheets(1)
　RowCnt = 4
　Do
　　If tgSh.Cells(RowCnt, 1).Value = "" Then Exit Do
　　MakeArrow tgSh, RowCnt, 8, 1
　　MakeArrow tgSh, RowCnt, 8, 2
　　RowCnt = RowCnt + 1
　Loop
End Sub

Sub sample2()　'図形を全数削除
　Dim RowCnt As Long
　Dim tgSh As Worksheet
　Set tgSh = ThisWorkbook.Sheets(1)
　RowCnt = 4
　Do
　　If tgSh.Cells(RowCnt, 1).Value = "" Then Exit Do
　　DelArrow tgSh, RowCnt, 1
　　DelArrow tgSh, RowCnt, 2
　　RowCnt = RowCnt + 1
　Loop
End Sub

Sub sample3()　'図形の表示開始位置、表示最終位置を変更
　Dim RowCnt As Long
　Dim tgSh As Worksheet
　Dim SCol1 As Long
　Dim ECol1 As Long
　Dim SCol2 As Long
　Dim ECol2 As Long

　Set tgSh = ThisWorkbook.Sheets(1)
　RowCnt = 4

　Do
　　If tgSh.Cells(RowCnt, 1).Value = "" Then Exit Do
　　SCol1 = tgSh.Cells(RowCnt, 1).Value - DateSerial(2019, 12, 31) + 8
　　ECol1 = tgSh.Cells(RowCnt, 2).Value - DateSerial(2019, 12, 31) + 9
　　SCol2 = tgSh.Cells(RowCnt, 6).Value - DateSerial(2019, 12, 31) + 8
　　ECol2 = tgSh.Cells(RowCnt, 7).Value - DateSerial(2019, 12, 31) + 9
　　EditArrow tgSh, RowCnt, SCol1, ECol1, 1
　　EditArrow tgSh, RowCnt, SCol2, ECol2, 2
　　RowCnt = RowCnt + 1
　Loop
End Sub

'//================================初期表示
Sub MakeArrow(Sh As Worksheet, SRow As Long, Scol As Long, MyPosCode As Long)
　'MyPosCode 表示位置（上下）1:上から1/3　2:上から2/3
　Dim MyPos As Double
　Dim ArrowName As String
　ArrowName = "Zu" & Format(SRow, "0000") & Format(MyPosCode, "0")
　If MyPosCode = 1 Then
　　MyPos = Sh.Cells(SRow, Scol).Height / 3
　Else
　　MyPos = Sh.Cells(SRow, Scol).Height / 3 * 2
　End If
　With Sh.Shapes.AddConnector( _
　　Type:=msoConnectorStraight, _
　　BeginX:=Range(Sh.Cells(SRow, Scol), Sh.Cells(SRow, Scol)).Left, _
　　Beginy:=Range(Sh.Cells(SRow, Scol), Sh.Cells(SRow, Scol)).Top + MyPos, _
　　EndX:=Range(Sh.Cells(SRow, Scol + 1), Sh.Cells(SRow, Scol + 1)).Left, _
　　EndY:=Range(Sh.Cells(SRow, Scol), Sh.Cells(SRow, Scol)).Top + MyPos)
　 .Line.EndArrowheadStyle = msoArrowheadStealth
　 .Name = ArrowName
　End With
　'Sh.Shapes.Range(Array(ArrowName)).Visible = False　 '※本番用
　Sh.Shapes.Range(Array(ArrowName)).Visible = True　　'※デバック用
End Sub

'//================================削除
Sub DelArrow(Sh As Worksheet, SRow As Long, MyPosCode As Long)
　Dim ArrowName As String
　ArrowName = "Zu" & Format(SRow, "0000") & Format(MyPosCode, "0")
　Sh.Shapes.Range(Array(ArrowName)).Delete
End Sub

'//================================開始位置、終了位置を変更して表示する
Sub EditArrow(Sh As Worksheet, SRow As Long, Scol As Long, ECol As Long, MyPosCode As Long)
　Dim MyPos As Double
　Dim ArrowName As String
　ArrowName = "Zu" & Format(SRow, "0000") & Format(MyPosCode, "0")
　Sh.Shapes(ArrowName).Left = _
　　Range(Sh.Cells(SRow, Scol), Sh.Cells(SRow, Scol)).Left
　Sh.Shapes(ArrowName).Width = _
　　Range(Sh.Cells(SRow, ECol), Sh.Cells(SRow, ECol)).Left - _
　　Range(Sh.Cells(SRow, Scol), Sh.Cells(SRow, Scol)).Left
　Sh.Shapes.Range(Array(ArrowName)).Visible = True
End Sub

回答No.2

HohoPapa

面白そうで、私も今後使うかもしれないので書いてみました。
I列が必ず1日である。という条件でよければ
以下のコードはいかがでしょうか？

sample1は、予め矢印を配置するコードです。
最終的に使うときは、
　'Sh.Shapes.Range(Array(ArrowName)).Visible = False　 '※本番用
　Sh.Shapes.Range(Array(ArrowName)).Visible = True　　'※デバック用
後者をコメントアウトし、前者を生かしてください。

sample2は、配した図を全数削除するコードです。
sample3が、配した図を求めに応じて、開始位置終了位置を変更するコードです。

Sub sample1()　'図形を初期配置
　Dim RowCnt As Long
　Dim tgSh As Worksheet
　Set tgSh = ThisWorkbook.Sheets(1)
　RowCnt = 4
　Do
　　If tgSh.Cells(RowCnt, 1).Value = "" Then Exit Do
　　MakeArrow tgSh, RowCnt, 8, 1
　　MakeArrow tgSh, RowCnt, 8, 2
　　RowCnt = RowCnt + 1
　Loop
End Sub

Sub sample2()　'図形を全数削除
　Dim RowCnt As Long
　Dim tgSh As Worksheet
　Set tgSh = ThisWorkbook.Sheets(1)
　RowCnt = 4
　Do
　　If tgSh.Cells(RowCnt, 1).Value = "" Then Exit Do
　　DelArrow tgSh, RowCnt, 1
　　DelArrow tgSh, RowCnt, 2
　　RowCnt = RowCnt + 1
　Loop
End Sub

Sub sample3()　'図形の表示開始位置、表示最終位置を変更
　Dim RowCnt As Long
　Dim tgSh As Worksheet
　Set tgSh = ThisWorkbook.Sheets(1)
　RowCnt = 4
　Do
　　If tgSh.Cells(RowCnt, 1).Value = "" Then Exit Do
　　EditArrow tgSh, RowCnt, Day(tgSh.Cells(RowCnt, 1).Value) + 8, _
　　　Day(tgSh.Cells(RowCnt, 2).Value) + 9, 1
　　EditArrow tgSh, RowCnt, Day(tgSh.Cells(RowCnt, 6).Value) + 8, _
　　　Day(tgSh.Cells(RowCnt, 7).Value) + 9, 2
　　RowCnt = RowCnt + 1
　Loop
End Sub

'//================================初期表示
Sub MakeArrow(Sh As Worksheet, SRow As Long, Scol As Long, MyPosCode As Long)
　'MyPosCode 表示位置（上下）1:上から1/3　2:上から2/3
　Dim MyPos As Double
　Dim ArrowName As String
　ArrowName = "Zu" & Format(SRow, "0000") & Format(MyPosCode, "0")
　If MyPosCode = 1 Then
　　MyPos = Sh.Cells(SRow, Scol).Height / 3
　Else
　　MyPos = Sh.Cells(SRow, Scol).Height / 3 * 2
　End If
　With Sh.Shapes.AddConnector( _
　　Type:=msoConnectorStraight, _
　　BeginX:=Range(Sh.Cells(SRow, Scol), Sh.Cells(SRow, Scol)).Left, _
　　Beginy:=Range(Sh.Cells(SRow, Scol), Sh.Cells(SRow, Scol)).Top + MyPos, _
　　EndX:=Range(Sh.Cells(SRow, Scol + 1), Sh.Cells(SRow, Scol + 1)).Left, _
　　EndY:=Range(Sh.Cells(SRow, Scol), Sh.Cells(SRow, Scol)).Top + MyPos)
　 .Line.EndArrowheadStyle = msoArrowheadStealth
　 .Name = ArrowName
　End With
　'Sh.Shapes.Range(Array(ArrowName)).Visible = False　 '※本番用
　Sh.Shapes.Range(Array(ArrowName)).Visible = True　　'※デバック用
End Sub

'//================================削除
Sub DelArrow(Sh As Worksheet, SRow As Long, MyPosCode As Long)
　Dim ArrowName As String
　ArrowName = "Zu" & Format(SRow, "0000") & Format(MyPosCode, "0")
　Sh.Shapes.Range(Array(ArrowName)).Delete
End Sub

'//================================開始位置、終了位置を変更して表示する
Sub EditArrow(Sh As Worksheet, SRow As Long, Scol As Long, ECol As Long, MyPosCode As Long)
　Dim MyPos As Double
　Dim ArrowName As String
　ArrowName = "Zu" & Format(SRow, "0000") & Format(MyPosCode, "0")
　Sh.Shapes(ArrowName).Left = _
　　Range(Sh.Cells(SRow, Scol), Sh.Cells(SRow, Scol)).Left
　Sh.Shapes(ArrowName).Width = _
　　Range(Sh.Cells(SRow, ECol), Sh.Cells(SRow, ECol)).Left - _
　　Range(Sh.Cells(SRow, Scol), Sh.Cells(SRow, Scol)).Left
　Sh.Shapes.Range(Array(ArrowName)).Visible = True
End Sub

回答No.1

kkkkkm

たとえば既に存在する矢印(名前が直線矢印コネクタ 1として)をオレンジ色の所に配置でしたら

ActiveSheet.Shapes.Range(Array("直線矢印コネクタ 1")).Left = Range("I4").Left
ActiveSheet.Shapes.Range(Array("直線矢印コネクタ 1")).Width = Range("M4").Left - Range("I4").Left
ActiveSheet.Shapes.Range(Array("直線矢印コネクタ 1")).Top = Range("I4").Top + Range("I4").RowHeight / 2

新しく矢印を引く場合は以下のサイトを参考に
https://xtech.nikkei.com/it/atcl/column/15/090100207/090100086/