Excelの通常の機能の中には、自動でオートシェイプの線を引く事や、自動でオートシェイプの(色や長さ等の)設定を変更する様な事を実現出来る機能は御座いませんので、マクロ等による方法を用いるしか御座いません。
それで、タイトル行が何行目の行なのか何も説明が御座いませんので、取り敢えず仮の話として、タイトル行が2行目の行である場合に対応するVBAのマクロを御伝え致します。
尚、タイトル行が別の行である場合には、下記のVBAの構文の中で、
Const ItemRow = 2 'タイトル行
と記述されている行の中の
2
と記されている箇所を、実際のタイトル行の行番号に合わせて変更して下さい。
そして、下記のマクロの使い方に関してですが、まず、Excelのウィンドウの上の方にある[開発]タブをクリックすると現れる「コード」グループ内の[Visual Basic]ボタンをクリックして下さい。
すると、「Microsoft Visual Basic for Applications」というウィンドウが現れますので、その中の「プロジェクト - VBAProject」という欄内に、
Sheet1(Sheet1)
Sheet2(Sheet2)
Sheet3(Sheet3)
・
・
・
などという具合に並んでいるシートモジュールの内、御質問の様な処理を行いたいシートのシート名が " ( )内に " 表示されているシートモジュールにカーソルを合わせて、マウスの左ボタンをダブルクリックして下さい。
その上で以下のVBAの構文を「Microsoft Visual Basic for Applications」ウィンドウの右側の欄に入力して下さい。
Private Sub Worksheet_Change(ByVal Target As Range)
'QNo.9113410 日付データで自動でオートシィプの線を引く
Const ItemRow = 2 'タイトル行
Const StartDateColumn = "B" '期間の開始日が入力されている列
Const EndDateColumn = "C" '期間の終了日が入力されている列
Const FirstDayColumn = "D" 'タイトル行において最も古い日付の日の値を入力する列
Dim LastRow As Long, FirstDay As Date, LastDay As Date, StartDate As Variant, _
EndDate As Variant, myShape As Shape, temp As Variant, c As Range, i As Long
If Intersect(Target, Range(StartDateColumn & ":" & StartDateColumn & "," _
& EndDateColumn & ":" & EndDateColumn), Range(ItemRow + 1 _
& ":" & Cells.SpecialCells(xlCellTypeLastCell).row + 1)) _
Is Nothing Then Exit Sub
LastRow = Range(StartDateColumn & Rows.Count).End(xlUp).row
temp = Range(EndDateColumn & Rows.Count).End(xlUp).row
If LastRow < temp Then LastRow = temp
If LastRow <= ItemRow Then Exit Sub
FirstDay = DateSerial(9999, 12, 31)
LastDay = DateSerial(1904, 1, 1)
For i = ItemRow + 1 To LastRow
StartDate = Range(StartDateColumn & i).Value
If StartDate > DateSerial(1904, 1, 1) And StartDate < FirstDay Then FirstDay = StartDate
EndDate = Range(EndDateColumn & i).Value
If EndDate > LastDay And EndDate < DateSerial(9999, 12, 31) Then LastDay = EndDate
Next i
With Application
.ScreenUpdating = False
.Calculation = xlManual
End With
With Range(Range(FirstDayColumn & ItemRow), _
Cells(LastRow, Cells(ItemRow, Columns.Count).End(xlToLeft).column + 1))
.Range(Range(FirstDayColumn & ItemRow), Cells(ItemRow, _
Cells(ItemRow, Columns.Count).End(xlToLeft).column + 1)).ClearContents
For Each myShape In ActiveSheet.Shapes
Set c = Range(myShape.TopLeftCell, myShape.BottomRightCell)
If Not (Intersect(c, Range(FirstDayColumn & ItemRow + 1 & ":" _
& Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 1).Address)) Is Nothing) _
Then myShape.Delete
Next myShape
End With
For i = FirstDay To LastDay
With Range(FirstDayColumn & ItemRow).Offset(, i - FirstDay)
.Value = i
.NumberFormatLocal = "d"
End With
Next i
For i = ItemRow + 1 To LastRow
StartDate = Range(StartDateColumn & i).Value
EndDate = Range(EndDateColumn & i).Value
If StartDate > DateSerial(1904, 1, 1) And EndDate < DateSerial(9999, 12, 31) _
And StartDate <= EndDate Then
Set c = Range(FirstDayColumn & i). _
Offset(, StartDate - FirstDay).Resize(, EndDate - StartDate + 1)
With ActiveSheet.Shapes.AddConnector(msoConnectorStraight, _
c.Left, c.Top + c.Height / 2, c.Left + c.Width, c.Top + c.Height / 2).Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.Transparency = 0
.Style = msoLineSingle
.Weight = 2
.EndArrowheadStyle = msoArrowheadTriangle
.EndArrowheadLength = msoArrowheadLengthMedium
.EndArrowheadWidth = msoArrowheadWidthMedium
End With
End If
Next i
With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
End With
End Sub
以上で準備は完了で、後はタイトル行よりも下の行のB列のセルに開始日を、C列のセルに終了日をそれぞれ入力するだけで、終了日の右側に並んでいる日付が、全ての開始日と終了日を含む期間に合わせて書き換えられた上で、タイトル行よりも下の行には開始日と終了日に対応した位置にオートシェイプの矢印が表示される様になります。(開始日と終了日のどちらか一方でも手作業で消去された場合には、その行の矢印も自動的に削除されます)
補足
回答ありがとうございます 実行してみましたが dim x1 as double, x2 as double, yy s double で構文エラーが出てしまいました