日付データで自動でオートシィプの線を引く

質問

A列に内容
B列に開始日
C列に終了日を日付で入力し
タイトル行に1日おきの日付を入力しサンプルのように
開始日から終了日までオートシェイプで線を自動で引くには
どうしたら良いでしょうか

回答No.5

keithin

ありゃごめんなさい，誤記を直し忘れてました。

誤記：
　dim x1 as double, x2 as double, yy s double

訂正：
　dim x1 as double, x2 as double, yy as double

失礼しました。

回答No.4

kagakusuki

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列のセルに終了日をそれぞれ入力するだけで、終了日の右側に並んでいる日付が、全ての開始日と終了日を含む期間に合わせて書き換えられた上で、タイトル行よりも下の行には開始日と終了日に対応した位置にオートシェイプの矢印が表示される様になります。(開始日と終了日のどちらか一方でも手作業で消去された場合には、その行の矢印も自動的に削除されます)

回答No.3

keithin

１行目をタイトル行、２行目からデータとして
Ｂ列に開始日、Ｃ列に終了日として
１行目には「１５」「１６」のように「日」だけが生数字で記入してあるとして。

手順：
ＡＬＴ＋Ｆ１１を押す
現れた画面で挿入メニューから標準モジュールを挿入する
現れたシートに下記をコピー貼り付ける

sub macro1()
　dim r as long
　dim c1 as long, c2 as long
　dim x1 as double, x2 as double, yy s double

　for r = 2 to range("A65536").end(xlup).row
　　if isdate(cells(r, "B")) and isdate(cells(r, "C")) then
　　　c1 = application.match(day(cells(r, "B")), rows(1), 0)
　　　c2 = application.match(day(cells(r, "C")), rows(1), 0)
　　　x1 = cells(r, C1).left
　　　x2 = cells(r, C2).left + cells(r, C2).width
　　　yy = cells(r, C1).top + cells(r, C1).height / 2

　　　on error resume next
　　　activesheet.shapes("arrow_" & r).delete
　　　on error goto 0

　　　with activesheet.shapes.addconnector(msoconnectorstraight, x1, yy, x2, yy)
　　　　.shaperange.line.endarrowheadstyle = msoarrowheadopen
　　　　.name = "arrow_" & r
　　　end with

　　end if
　next r
end sub

ファイルメニューから終了してエクセルに戻る
ＡＬＴ＋Ｆ８を押し、マクロを実行する。

補足

回答ありがとうございます

実行してみましたが　
　dim x1 as double, x2 as double, yy s double
で構文エラーが出てしまいました

回答No.2

msMike

[No.1]の式は次の方が首尾一貫してますね。済みません。
=AND(DAY($B2)<=D$1,DAY($C2)>=D$1)

回答No.1

msMike

単なる塗りつぶしで御免(*^_^*)
条件付き書式のための数式は次のとおり
=AND(DAY($B2)<D$1+1,DAY($C2)>=D$1)

【独白】オートシヱイプ矢印でも可能なのだらうか？いえ、私はさうは思はない！