カレンダーのイベント期間に矢印を引いてテキスト入力したい

カレンダー上にイベント期間分の矢印線を引き、開始項目、終了項目を自動入力できるマクロを考えています。
予め期間指定してある状態で線を引く下記マクロはできました。
これにBP列から始まる表に記載された開始期間、「終了期間」を参照して、「開始項目」、「終了項目」を図のように自動表示することは可能でしょうか？


Sub 矢印()
Dim R As Range
Set R = Selection
With ActiveSheet.Shapes.AddLine(R.Left, R.Top + R.Height / 2, R.Left + R.Width, R.Top + R.Height / 2).Line
.ForeColor.RGB = RGB(0, 0, 255)
.Style = 1
.BeginArrowheadStyle = 3
.EndArrowheadStyle = 3
.Weight = 3
End With
End Sub

No.1 ベストアンサー 回答者： fujillin 回答日時： 2021/05/25 14:11

こんにちは

回答者には質問で提示されている情報が全てで、それ以外の（頭の中の）情報はわかりません。
その観点からは、情報が少なすぎるので、回答なさる方は少ないと想像されます。
中途半端なコードを載せるよりも、きちんと内容を説明することの方が大切かと思います。
（添付の図とコードも一致していないので、混乱させるだけ）

たまたま、前回のご質問に回答しているので、多少は推測できるのですが、それでもいろいろと勝手に仮定した上での回答です。

・想定条件が多いので内容は省略。
　（動かなければ、想定が違っているものと思ってください）
・当たるも八卦なので、表示だけのサンプルです。
　（既存の値やShapeは消去しません。）
・違っていても（多分）マクロの構成は利用できるのではないかと想像します。

Sub Sample_Q12376646()
Dim rw As Long, dh As Single
Dim cStart As Range, cEnd As Range

For rw = 8 To Cells(Rows.Count, 68).End(xlUp).Row
Set cStart = Cells(rw, 68)
Set cEnd = Cells(rw, 69)
If IsDate(cStart) And IsDate(cEnd) Then
If cStart < Cells(6, 3) Then Set cStart = Cells(6, 3)
If cStart < cEnd Then

Set cStart = Cells(rw, 2).Offset(, WorksheetFunction.Match(cStart, Range("C6:BN6"), 1))
Set cEnd = Cells(rw, 2).Offset(, WorksheetFunction.Match(cEnd, Range("C6:BN6"), 1))
cStart.Value = Cells(rw, 70).Value
cEnd.Value = Cells(rw, 71).Value
dh = cEnd.Top + cEnd.Height - Application.Max(cEnd.Height / 4, 5)

With ActiveSheet.Shapes.AddLine(cStart.Left, dh, cEnd.Left + cEnd.Width, dh).Line
.Style = msoLineSingle
.ForeColor.RGB = 0
.Weight = 2
.BeginArrowheadStyle = msoArrowheadNone
.EndArrowheadStyle = msoArrowheadTriangle
.EndArrowheadLength = msoArrowheadLong
.EndArrowheadWidth = msoArrowheadWide
End With
End If
End If
Next rw
End Sub

この回答へのお礼

質問の説明不足な点、申し訳ございません。
昨日に続き完璧な内容です。
助かりました、ありがとうございます。

お礼日時：2021/05/25 17:27