『日程表に矢印を書きたい』（ふみ）

Windows　XP,Excel２００７を使用しています。

日程表の開始日付をカレンダーから選択し（A7)、
矢印を書く開始日をカレンダーから選択し、
矢印を書く終了日をカレンダーから選択すると、
日程表に矢印が書ける様にしたいのですが、
今のコードは矢印を書く範囲全体のセルに
矢印を書いてしまい、範囲全体のセルの中に不明な日付を
記入してしまいます。

完成時には、B12開始C12終了からB43開始C43終了まで、
D12開始E12終了からD43開始E43終了まで、
たくさんの矢印を書きたいのですが、
今は最初のB12開始C12終了の矢印が書けなくて困っています。

どこを直したら良いのでしょうか？
よろしくお願いします。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

     If Not Intersect(Target, Range("a7,b12:e43")) Is Nothing Then
     
         ActiveSheet.Calendar1.Visible = True
         
         ActiveSheet.Calendar1.Value = Date
     
        
     End If
     
     If Not Intersect(ActiveCell, Range("a7,b12:e43")) Is Nothing Then
     
     ActiveSheet.Calendar1.Visible = True
         
         ActiveSheet.Calendar1.Value = Date
     

     Else

     ActiveSheet.Calendar1.Visible = False
     
     End If

 End Sub


Private Sub Calendar1_Click()

If Not Intersect(ActiveCell, Range("a7,b12:e43")) Is Nothing Then

ActiveCell = Calendar1.Value

ActiveSheet.Calendar1.Visible = False

Else

ActiveSheet.Calendar1.Visible = False

End If


    

    
    Dim dtStDate As Range, dtEdDate1 As Range, dtEdDate2 As Range
    
    Set dtStDate = Range("a7")
    Set dtEdDate1 = Range("b12")
    Set dtEdDate2 = Range("c12")
    
    
Dim rngStart As Range, rngEnd As Range
    Dim BX As Single, BY As Single, EX As Single, EY As Single
    
    Set rngStart = Range("$f$12:$cs$12")
    
    Set rngEnd = Range("$f$12:$cs$12")
    
 rngStart = Range("e12") + DateDiff("d", dtStDate, dtEdDate1)
     
 rngEnd = Range("e12") + DateDiff("d", dtStDate, dtEdDate2)
 

    
    
    BX = rngStart.Left
    BY = rngStart.Top
    EX = rngEnd.Left + rngEnd.Width
    EY = rngEnd.Top
    
    
    
    With ActiveSheet.Shapes.AddLine(BX, BY + 10, EX, EY + 10).Line
        .ForeColor.RGB = vbRed
        .Weight = 5
        .EndArrowheadStyle = msoArrowheadTriangle
    End With

End Sub





（初心者）
----
 表の構成が分からないとなんとも言えません。
 B12,C12,E12にはそれぞれ何が入りますか？
 （稲葉）2013/10/01(火曜日)　13:28
----
稲葉さん、御質問ありがとう御座います。

今のところ、まだE12は使用していません。

A7にカレンダーコントロールから日付を指定して
日程表の開始日を入力します。

日程表は指定した日付が先頭に変わる様に作っています。

B12にある工程の開始日を、またC12にその工程の終了日を
同じ様にカレンダーコントロールから選択して日付を入れます。
するとその期間だけ、矢印が書かれる様にしたいのですが、
今のコードでは出来ていません。

開始日のセルと終了日のセルを指定する事が出来れば良いと
思うのですが、どうすれば良いかわからなくて困っています。

よろしくお願いします。

（初心者）
----
 一個ずつ回答します。

 ＞範囲全体のセルの中に不明な日付を記入してしまいます。 
 これは、↓のコードの部分で実行されています。
 上部2行でrangeオブジェクトを変数に入れて
 下部2行でE12+（工程開始日から工程終了日までの日数）をセルに代入しています。
 たぶん1セルを1日分として、処理したいので、DateDiffを使っていますが、「日（d）」だけなら
 引き算で十分でしょう。
 ＞   Set rngStart = Range("$f$12:$cs$12")
 ＞   Set rngEnd = Range("$f$12:$cs$12")

 ＞   rngStart = Range("e12") + DateDiff("d", dtStDate, dtEdDate1)
 ＞   rngEnd = Range("e12") + DateDiff("d", dtStDate, dtEdDate2)

 -*-*-*-*-*-*-*-*-
 ＞今のコードは矢印を書く範囲全体のセルに矢印を書いてしまい
 ↑でセットした最初と最後のセルの位置情報を元に、オブジェクトを挿入している為です。

 ＞   BX = rngStart.Left
 ＞   BY = rngStart.Top
 ＞   EX = rngEnd.Left + rngEnd.Width
 ＞   EY = rngEnd.Top



 次に確認です。
 １、A7が日程表の開始日
 ２、B12が工程の開始日
 ３、C12が工程の終了日

 １＜２の場合、どうしますか？
 ３＜２の場合、どうしますか？

 表のイメージは以下の感じですか？
 
	[A]		[B]		[C]		[D]	[E]	[F]	[G]	[H]	[I]	[J]
[6]	日程表開始日									
[7]	2013/10/1									
[8]										
[9]										
[10]										
[11]			工程開始日	工程終了日							
[12]			10/2		10/5		10/1	10/2	10/3	10/4	10/5	10/6	10/7
[13]								―	―	―	→		

 （稲葉）2013/10/01(火曜日)　15:29

 【補足】
 それとも、日付は12行目から43行目まで固定？
	[A]		[B]		[C]		[D]	[E]	[F]	[G]	[H]	[I]	[J]
[6]	日程表開始日												
[7]	2013/10/1												
[8]													
[9]													
[10]													
[11]			工程開始日	工程終了日	10/1	10/2	10/3	10/4	10/5	10/6	10/7		
[12]			10月2日		10月5日			―	―	―	→		
[13]								
 （稲葉）2013/10/01(火曜日)　15:34					
												
		
	

----
 とりあえず↓のほうな表で出来るように手を加えてみました。

	[A]		[B]		[C]		[D]	[E]	[F]	[G]
[6]	日程表開始日									
[7]	2013/10/1									
[8]										
[9]										
[10]										
[11]			工程開始日	工程終了日			10/1	10/2	10/3	10/4	10/5	10/6
[12]			10月2日		10月5日					―	―	―	→
[13]										

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim MYR As Long
    Dim STD As Variant
    Dim LAD As Variant
    Dim X As Variant
    Dim Y As Variant
    Dim i As Long
    X = Range("A7").Value
    Y = X + 91                 'CS列まで
    Application.EnableEvents = False
    
    If Not Intersect(Target, Range("B12:E43")) Is Nothing Then
        MYR = Target.Row
        STD = Cells(MYR, "B").Value
        LAD = Cells(MYR, "C").Value
        Select Case True
            Case X > STD, Y < LAD
                Call 矢印削除(CStr(MYR))
                GoTo er
            Case Else
                Call 矢印(MYR, STD, LAD)
        End Select
    ElseIf Not Intersect(Target, Range("A7")) Is Nothing Then
        For i = 12 To 43
            STD = Cells(i, "B").Value
            LAD = Cells(i, "C").Value
            Select Case ""
                Case STD, LAD, IIf(STD > LAD, "", True)
                    GoTo er
                Case Else
                    Call 矢印(i, STD, LAD)
            End Select
        Next
    End If
er:
    Range("A1").Select
    Application.EnableEvents = True
End Sub
Sub 矢印(r As Long, S As Variant, t As Variant)
    Dim tbl As Variant
    Dim SC As Range
    Dim LC As Range
    Dim LN As Shape
    
    tbl = Range("F11:CS11").Value
    With Application.WorksheetFunction
        Set SC = Cells(r, .Match(S, tbl, 0) + 5)
        Set LC = Cells(r, .Match(t, tbl, 0) + 5 + 1)
    End With
    
    Call 矢印削除(CStr(r))
    
    With ActiveSheet.Shapes.AddLine(SC.Left, SC.Top + 10, LC.Left, LC.Top + 10)
        .Name = "直線" & r
        With .Line
            .ForeColor.RGB = vbRed
            .Weight = 5
            .EndArrowheadStyle = msoArrowheadTriangle
        End With
    End With
    
End Sub
Sub 矢印削除(Optional n As String = "*")
    For Each sp In ActiveSheet.Shapes
        If sp.Name Like "直線" & r & "*" Then
            sp.Delete
        End If
    Next
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
     If Not Intersect(Target, Range("a7,b12:e43")) Is Nothing Then
         ActiveSheet.Calendar1.Visible = True
         ActiveSheet.Calendar1.Value = Date
     End If
     If Not Intersect(ActiveCell, Range("a7,b12:e43")) Is Nothing Then
        ActiveSheet.Calendar1.Visible = True
        ActiveSheet.Calendar1.Value = Date
     Else
        ActiveSheet.Calendar1.Visible = False
     End If
 End Sub

Private Sub Calendar1_Click()
    If Not Intersect(ActiveCell, Range("a7,b12:e43")) Is Nothing Then
        ActiveCell = Calendar1.Value
        ActiveSheet.Calendar1.Visible = False
    Else
        ActiveSheet.Calendar1.Visible = False
    End If
End Sub

 （稲葉）2013/10/01(火曜日)　18:24

----
 面白そうなので、参考出品。
 どうも見直してみると仕様を勘違いしているようですけれど、
 F12:CS12 までずらっと日付があって、
 B13、C13 に日付を入れると 13 行目の該当区間に矢印
 D13、E13 に日付を入れると 13 行目の該当区間に矢印
 以下14行から43行まで同様、という仕様で作成してしまいました。

 実際の仕様とあまりに違うようでしたら、読み飛ばしてください。
 Selection_Change も使い勝手が悪そうだったので、勝手に右クリックにしています。

 日付の Find も書式やデータの持ち方で難しそうなので関数を作成しています。
http://officetanaka.net/excel/vba/tips/tips131b.htm
 いやぁ、勉強になりました（ハマったぁ・・・）。

 ご参考までに。

 '//-------------------
 Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
 '//-------------------
 '//  右クリックでカレンダー入力
 '//-------------------
    If Target.Count <> 1 Then Exit Sub
    If Not Intersect(Target, Range("A7,B12:E43")) Is Nothing Then
        ActiveSheet.Calendar1.Visible = True
        ActiveSheet.Calendar1.Value = Date
        Cancel = True
    Else
        ActiveSheet.Calendar1.Visible = False
    End If
 End Sub

 '//-------------------
 Private Sub Calendar1_Click()
 '//-------------------
    If Intersect(ActiveCell, Range("A7,B12:E43")) Is Nothing Then Exit Sub
    
    ActiveCell = Calendar1.Value
    ActiveSheet.Calendar1.Visible = False

    drawArrow Cells(ActiveCell.Row, 2), True
    drawArrow Cells(ActiveCell.Row, 4), False
 End Sub

 '//-------------------
 Private Sub drawArrow(dtCell As Range, removeShape As Boolean)
 '//-------------------
 '//  矢印描画処理
 '//-------------------
    If dtCell.Value = "" Or dtCell.Offset(0, 1).Value = "" Then Exit Sub

    Dim stDate As Range
    Set stDate = findDate(dtCell, Range("$F$12:$CS$12"))
        
    Dim edDate As Range
    Set edDate = findDate(dtCell.Offset(0, 1), Range("$F$12:$CS$12"))

    If stDate Is Nothing Or edDate Is Nothing Then
        MsgBox "指定日付がありません"
        Exit Sub
    End If

    Dim sh As Shape
    If removeShape = True Then
        For Each sh In ActiveSheet.Shapes
            If sh.TopLeftCell.Row = dtCell.Row Then
                sh.Delete
            End If
        Next
    End If

    With ActiveSheet.Shapes.AddLine(stDate.Left, dtCell.Top + dtCell.Height / 2, edDate.Left + edDate.Width, dtCell.Top + dtCell.Height / 2).Line
        .ForeColor.RGB = vbRed
        .Weight = 5
        .EndArrowheadStyle = msoArrowheadTriangle
    End With
 End Sub

 '//-------------------
 Function findDate(keyDate As Range, calDate As Range) As Range
 '//-------------------
 '//  日付検索関数
 '//-------------------
    Dim r As Range
    For Each r In calDate
        If r.Value2 = keyDate.Value2 Then
            Set findDate = r
            Exit Function
        End If
    Next
    Set findDate = Nothing
 End Function

 (Mook)



----
稲葉さん、Mookさん、ありがとう御座います。

書いて頂いたコードを走らせてみましたが、
残念ながら矢印を書く事が出来ません。

表の構成は、

	[A]		　[B]		[C]		　　[D]	　　　　　[E]	　　　　[F]	　　[G]
[6]	日程表開始日									
[7]	2013/10/1									
[8]										
[9]										
[10]										
[11]			計画工程開始日	計画工程終了日	実績工程開始日　実績工程終了日		10/1	10/2	10/3	10/4	10/5	10/6
[12]			10月2日		10月5日					　　　　　　　　　　　　―	―	―	→
[13]										
で、１２行目から４３行目まで、２セルずつを使って１６項目の工程の
日付を計画と実績でカレンダーコントロールから入力し、
計画と実績の矢印の色を変えて確認出来る様にしようと思っています。
１２行目の計画が１２行目の矢印、１２行目の実績が１３行目の矢印、
で、４２行目の計画が４２行目の矢印、実績が４３行目の矢印です。

カレンダーコントロールはクリックしたら消える、
指定セル以外をクリックした時も消える様に考えています。
今は同じセルをクリックする時は、一旦他のセルをクリックしてからしか
カレンダーが現れないので、改善したいと思っています。

日程表開始日より以前の日付を入力しようとした時や、
工程開始日より以前の日付を工程終了日に入力しようとした時は
エラーメッセージで入力出来ない様にしようと思っています。


稲葉さんとMookさんのコードをこれから理解して、
なんとか考えているコードを作りたいと思いますが、
もし上記の構成で御教示頂ける様でしたら、
よろしくお願いします。
（初心者）

----
 ＞書いて頂いたコードを走らせてみましたが、 
 ＞残念ながら矢印を書く事が出来ません。 

 どうできなかったの？
 こちらは同じ環境で出来てから投稿しているわけですが。

 エラーメッセージは出ませんが、処理されないようにしています。
 何かしら入力があった場合、A1セルを選択するようにしているので、別のセルをクリックしてから
 もクリアしています。
 何がダメなんですか？
 （稲葉）2013/10/02(水曜日)　12:45
 
 



----
 どう動かなかったかは書いてもらえるとうれしいですね。

 こちらでは日付は12行想定だったので、提示された構成であるなら
  Range("$F$12:$CS$12") は  Range("$F$11:$CS$11") に変更が必要です。
 こちらは 2007/2010 環境なので、動かなかったらすみません。
 (Mook)
----
詳しく書かなくて申し訳有りません。

稲葉さんのは、最初にカレンダーをクリックすると、
Set SC = Cells(r, .Match(S, tbl, 0) + 5)のところでエラーが出て、
「WorksheetFunctionクラスのMatchプロパティを取得出来ません」
が表示されます。

そのあとはクリックしてもカレンダーが出なくなります。
もちろん矢印は書かれません。

Mookさんのは、A7を右クリックするとカレンダーが出ますが、
B12セルなど、他のセルでは出ません。

カレンダーをクリックすると、「指定日付がありません」と
メッセージが出ます。

Range("$F$12:$CS$12") を  Range("$F$11:$CS$11") に変更したら
メッセージは出なくなりましたが、矢印は書かれません。
エラーメッセージもありません。

確認して頂いてから投稿して頂いているのに申し訳ありません。
違いがわかりませんが、私の環境では上記の様になってしまいます。
（初心者）



----
 どちらも同じ「日付が見当たらない」エラーですね。
 クリックしてもカレンダーが出なくなったのは、イベント無効処理をしたままエラーになったせいです。

 適当なところに貼り付けて、実行してください。
Sub イベントスイッチ()
    Application.EnableEvents = True
End Sub    

 ただMookさんのほうを変えたらエラーが出なくなったのは？？？
 私の環境だとMookさんのほうも問題ありませんでした。

 １.11行目にある日付は、日付型のデータですか？文字列型ですか？
 ２.１.の日付は例えば F11=A7 , G11=F11+1 このような感じですか？

 （稲葉）2013/10/02(水曜日)　14:11
----
 「指定日付がありません」
 はエラーメッセージというようり、11行目の日付に指定日付が見つからない場合の
 終了時のメッセージです。

 日付は開始日と終了日（B&C or D&E）がないと何も処理しません。
 両方入れても動かないのであれば、別原因ですのでコメントください。

 まずは、ステップ実行を覚えるとよいかと思います。
http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_030.html
 (Mook)
----
 エラー処理のところちょっと変えてみたので、やってみてください。
 エラーの原因が知りたい。

'_/_/_/右クリックでカレンダーの表示
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    Dim FLG As Boolean
    With Target
        If .Rows.Count > 1 Or .Columns.Count > 1 Then Exit Sub
    End With
    
    FLG = False
    Select Case True
        Case Not Intersect(Target, Range("A7")) Is Nothing: FLG = True
        Case Not Intersect(Target, Range("B12:E49")) Is Nothing And Target.Row Mod 2 = 0: FLG = True
    End Select
    With ActiveSheet.Calendar1
        .Visible = FLG
        .Value = Date
    End With
    Cancel = True
End Sub

'_/_/_/カレンダークリックで値の代入
Private Sub Calendar1_Click()
    With ActiveCell
        If .Rows.Count > 1 Or .Columns.Count > 1 Then Exit Sub
    End With
    If Intersect(ActiveCell, Range("A7,B12:E43")) Is Nothing And ActiveCell.Row Mod 2 = 1 Then Exit Sub
    With ActiveSheet.Calendar1
        ActiveCell = .Value
        .Visible = False
    End With
End Sub


'_/_/_/右クリック以外のセルが選択されたら、カレンダーを非表示
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ActiveSheet.Calendar1.Visible = False
End Sub

'_/_/_/セルの値が書き換えられたら処理を開始
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Dis_Er As Boolean
    Dim i As Long
    With Target
        If .Rows.Count > 1 Or .Columns.Count > 1 Then Exit Sub
    End With
    Dis_Er = True
    
    Select Case True
        
        '//カレンダーの基準が変更された場合
        Case Not Intersect(Target, Range("A7")) Is Nothing
            If MsgBox("エラーメッセージを表示しますか？", vbYesNo) = vbNo Then Dis_Er = False
            For i = 12 To 49 Step 2
                Call Dr_Arw(i, Cells(i, "B").Value2, Cells(i, "C").Value2, vbRed, Dis_Er)
                Call Dr_Arw(i + 1, Cells(i, "D").Value2, Cells(i, "E").Value2, vbBlue, Dis_Er)
            Next i
        
        '//奇数行の場合、処理を中断
        Case Target.Row Mod 2 = 1: Exit Sub
        
        '//計画日の処理
        Case Not Intersect(Target, Range("B12:C49")) Is Nothing
            With Target
                Call Dr_Arw(.Row, Cells(.Row, "B").Value2, Cells(.Row, "C").Value2, vbRed, True)
            End With
        
        '//実績日の処理
        Case Not Intersect(Target, Range("D12:E49")) Is Nothing
            With Target
                Call Dr_Arw(.Row + 1, Cells(.Row, "D").Value2, Cells(.Row, "E").Value2, vbBlue, True)
            End With
    
    End Select
End Sub

'_/_/_/矢印描き描き
Private Sub Dr_Arw(r As Long, s As Variant, e As Variant, cl As Variant, Optional ByRef f As Boolean = True)
    Dim tbl As Variant      '//日付データの配列用変数
    Dim SC As Range         '//開始列のrangeオブジェクト変数
    Dim LC As Range         '//終了列のrangeオブジェクト変数
    Dim P As Variant        '//基準日のデータ用変数
    Dim ErMsg As String     '//エラーメッセージ用変数
    
    P = Range("A7").Value2
    ErMsg = ""
    
    '//エラー処理
    Select Case True
        Case P = "": ErMsg = "基準日を入力してください。"
        Case s = "" And e = "": ErMsg = "開始日と終了日を入力してください。"
        Case s = "" And e <> "": ErMsg = "開始日を入力してください。"
        Case s <> "" And e = "": ErMsg = "終了日を入力してください。"
        Case P > s: ErMsg = "基準日が開始日より大きいです。"
        Case P > e: ErMsg = "基準日が終了日より大きいです。"
        Case s > e: ErMsg = "開始日が終了日より大きいです。"
        Case e - s > Range("F11:CS11").Columns.Count: ErMsg = "期間が日程に対して長すぎます。"
    End Select
    
    If Len(ErMsg) > 0 Then
        If f Then
            If MsgBox(ErMsg & vbNewLine & "キャンセルでエラーメッセージオフ", vbOKCancel) = vbCancel Then f = False
        End If
        Call Del_Arw(r)
        Exit Sub
    End If
    
    '//日付の検索
    tbl = Range("F11:CS11").Value2
    With Application.WorksheetFunction
        On Error GoTo match_er
        Set SC = Cells(r, .Match(s, tbl, 0) + 5)
        Set LC = Cells(r, .Match(e, tbl, 0) + 5 + 1)
        On Error GoTo 0
    End With
    
    Call Del_Arw(r)
    
    '//矢印の描写
    With ActiveSheet.Shapes.AddLine(SC.Left, SC.Top + SC.Height / 2, LC.Left, LC.Top + LC.Height / 2)
        .Name = "直線" & r
        With .Line
            .ForeColor.RGB = cl
            .Weight = 2
            .EndArrowheadStyle = msoArrowheadTriangle
        End With
    End With
    Exit Sub
    
match_er:
    ErMsg = _
        "s=" & s & " " & "e=" & e & vbNewLine & _
        "F11----------------------------" & vbNewLine & _
        "Value =" & Range("F11").Value & vbNewLine & _
        "Value2=" & Range("F11").Value2 & vbNewLine & _
        "Text  =" & Range("F11").Text & vbNewLine & _
        "Fomula=" & Range("F11").Formula & vbNewLine & vbNewLine & _
        "G11----------------------------" & vbNewLine & _
        "Value =" & Range("G11").Value & vbNewLine & _
        "Value2=" & Range("G11").Value2 & vbNewLine & _
        "Text  =" & Range("G11").Text & vbNewLine & _
        "Fomula=" & Range("G11").Formula

    MsgBox ErMsg
End Sub

'_/_/_/_/書くだけだとどんどん重なるので、消す必要がある
Private Sub Del_Arw(ByVal r As Long)
    Dim sp As Shape
    For Each sp In ActiveSheet.Shapes
        If sp.Name Like "直線" & r & "*" Then
            sp.Delete
        End If
    Next
End Sub


 （稲葉）2013/10/02(水曜日)　16:12
----
稲葉さん

Sub イベントスイッチ()
    Application.EnableEvents = True
End Sub    
を貼りつけましたが、状況は変わりません。

１１行目はごめんなさい、曜日を表示させています。
１０行目が日付ですが、先頭のF10は=A7、以降G10＝F10+1です。

これから頂いたコードをやってみます。

Mookさん

アドバイスを読んでRange("$F$11:$CS$11") を Range("$F$10:$CS$10") に変更したら 
矢印を書く様になりました。

問題点としてはA7しかカレンダーが出ない事と、矢印をB&CとD&Eの両方共12行目に
書いてしまう事です。
（初心者）




----
 うーん、こちらでは B12:E43 のどこでもカレンダーが出ますし、
 入力した日付の行に矢印が出ますけれど、何が違うのかな？。

 上の説明では日付は11行目に見えたのですが10行目なのですか？
 

 質問とは関係ありませんが、できれば（初心者）ではなく、質問者さんが
 識別できるニックネームにしていただけるとうれしいです。
 ここには（初心者）さんが何十人（何百人？）もいるようなので。
 (Mook)
----
Mookさん

日付の説明は間違えていました。申し訳有りません。
10行目が日付で11行目は曜日と気付きましたので変更しました。

Mookさんの方でどこでもカレンダーが出るのであれば、
カレンダーのver違いでしょうか？
こちらはエクセル2007なのですが、社内事情でアクセスは2003を
インストールしています。

カレンダーコントロールはアクセスの物を使用していると思うので、
この差でしょうか？
（初心者改め、ふみ）
----
 あ
 もしかしてセルの結合してませんか？
 ＞で、１２行目から４３行目まで、２セルずつを使って１６項目の工程の

 その場合、
 If .Rows.Count > 1 Or .Columns.Count > 1 Then Exit Sub
 が3か所あるので、
 If .Rows.Count > 2 Or .Columns.Count > 2 Then Exit Sub
 に書き変えてみてください。

 Mookさんのコードも
 Target.Count <> 1
 を
 Target.Count > 2
 に書き換えれば出来るはず。

 あと日付の行
    '//日付の検索
    tbl = Range("F11:CS11").Value2
 ここを書き換えてください。
 （稲葉）2013/10/02(水曜日)　16:45
 
 

 

----
 もし、セルの結合をしているのであれば私のは動きません。
 開始と終了が２セットある想定で作ってしまっていますので。

 カレンダーだけは出ると思いますが。
 (Mook)
----

稲葉さん

 '//日付の検索
    tbl = Range("F11:CS11").Value2
は気付いていたので10に変えて実行しました。

矢印は書ける様になりました。
ただ、カレンダーが実績の方で出ず、A7で出しても
実績のセルをクリックすると消えてしまうので
入力出来ません。

今から上のセル結合部分を修正してみます。
（初心者改め、ふみ）

Mookさん

稲葉さんのアドバイスで書き変えてみます。
（ふみ）
----
 ん？
 結合している、でいいのかな？
 あとこちらでは実績のところも「右クリック」でちゃんと出るんだけど、
 以下の条件に当てはまってる？

 １.セルの結合は行・列方向共に2セル以内（3セル以上を結合していない）
 ２.結合されたセルの左上のセル（例えばA2:B3の結合なら、A2のセル）は必ず偶数行にある
 ３.あたりまえだけどB12:E49の範囲内にある

 というか、ブレークポイント置いて見て、どこで止まってるか見てください。
http://www.vba-world.com/breakpoint.html

 （稲葉）2013/10/02(水曜日)　17:11

  
----
稲葉さん

セル結合部分を書き変えたらカレンダーが使える様になりました。
矢印の色も変えて頂き、イメージ通りです。
ありがとう御座います。

このコードを理解して、後の項目も矢印を書ける様にしたり、
細かな点を改善して行きます。

ありがとう御座いました。
（ふみ）

Mookさん

稲葉さんのアドバイスでカレンダーの問題は解決しました。
矢印が同じ行に書かれてしまうのを、明日考えてみます。
（ふみ）
----
 日付の検索に関しては、Mookさんの案を頂きました。（Value2）

 それから、老婆心ながら・・・
 先ほどからMookさんと私が言っている

 ＞まずは、ステップ実行を覚えるとよいかと思います。
http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_030.html

 ＞というか、ブレークポイント置いて見て、どこで止まってるか見てください。
http://www.vba-world.com/breakpoint.html

 これを覚えないと先がないので、是非覚えてください。
 （稲葉）2013/10/02(水曜日)　17:26 
----
稲葉さん

助言、ありがとう御座います。
言い訳になりますが、業務の合間を縫って作業しているので、
正直コードを理解したり調べたり、全然出来ていません。

どこか時間が出来た時に、教えて頂いたステップ実行とか
勉強したいです。

今はＮＥＴで参考になりそうなコードを見つけて
貼り合わせているだけなので、
基礎から勉強したいです。

ありがとう御座いました。
また、助けて下さい。
（ふみ）
----
 ニックネーム対応頂きありがとうございました。
 こちらも気持ちよく対応ができます。

 私の当初の想定は下記のようなものなので、セルの結合や日付の扱いが異なる場合は
 構成を再度説明ください。
	[A]　　[B]　　[C]　　[D]　　[E]　　[F]　　[G]　　[H]　　[I]　　[J]　　[K]
[11]										
[12]　　　　　　　　　　　　　　　　　　　　10/1　10/2　 10/3　 10/4　 10/5　 10/6
[13]	       10/1   10/2   10/4   10/5    −−−−→　　　　　−−−−→
[15]	       　　　　　　　10/2   10/4    　　　−−−−−−−−→
[16]	       10/2   10/5　　　　　　　    　　　−−−−−−−−−−−→
 (Mook)
----
Mookさん

構成は下記の様にしています。
B12B13、C12C13、D12D13、E12E13、B14B15,C14C15,の様にE42E43まで２セルずつ結合させています。

これでおわかりになるでしょうか？
不明なところがあれば御指摘下さい。

	[A]　　[B]　　[C]　　[D]　　[E]　　[F]　　[G]　　[H]　　[I]　　[J]　　[K]
[06] 日程表開始日
[07]　2013.10.01
[08]　　　　　　　　　　　　　　　　　　　　　10
[09]　　　　　　　　　　　　　　　　　　　　　月
[10]　　　　　　計　　画　　　実　　　績　　　1　　　2　　　3　　　4　　　5　　　6
[11]	　　　開始　　終了　開始　　終了　　火　　　水　　木　　　金　　土　　　日	
[12]　設計　　　10/1   10/2   10/4   10/5　　−−−−→　
[13]	           　　　　　　　　　　                          −−−−→
[14]　組立　　　10/2   10/4　 10/5   10/6　 　　　　　−−−−−−→
[15]	       　　　　　　　                                           −−−−→          　
（ふみ）	       　　　　　　　    　　　
----
 だいぶ想定と違っていましたねｗ。

 とりあえず、上記に合わせて修正しました。あちこち変わったので全体を再掲します。

 '//-------------------
 Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
 '//-------------------
 '//  右クリックでカレンダー入力
 '//-------------------
    If Not Intersect(Target, Range("A7,B12:E43")) Is Nothing Then
        ActiveSheet.Calendar1.Visible = True
        ActiveSheet.Calendar1.Value = Date
        Cancel = True
    Else
        ActiveSheet.Calendar1.Visible = False
    End If
 End Sub

 '//-------------------
 Private Sub Calendar1_Click()
 '//-------------------
    If Intersect(ActiveCell, Range("A7,B12:E43")) Is Nothing Then Exit Sub

    ActiveCell = Calendar1.Value
    ActiveSheet.Calendar1.Visible = False

    Select Case ActiveCell.Column
    Case 2, 3  '// B,C列
        drawArrow Cells(ActiveCell.Row, "B"), Cells(ActiveCell.Row, "C"), ActiveCell.Row, vbRed
    Case 4, 5  '// D,E列
        drawArrow Cells(ActiveCell.Row, "D"), Cells(ActiveCell.Row, "E"), ActiveCell.Row + 1, vbBlue
    End Select
 End Sub

 '//-------------------
 Private Sub drawArrow(stCell As Range, edCell As Range, drawRow As Long, arrowColor)
 '//-------------------
 '//  矢印描画処理
 '//-------------------
    Dim sh As Shape
    For Each sh In ActiveSheet.Shapes
        If sh.TopLeftCell.Row = drawRow Then
            sh.Delete
        End If
    Next

    If stCell.Value = "" Or edCell.Value = "" Then Exit Sub

    Dim stDate As Range
    Set stDate = findDate(stCell, Range("$F$10:$CS$10"))

    Dim edDate As Range
    Set edDate = findDate(edCell, Range("$F$10:$CS$10"))

    If stDate Is Nothing Or edDate Is Nothing Then
        MsgBox "指定日付がありません"
        Exit Sub
    End If

    Dim posY As Double
    posY = Cells(drawRow, "A").Top + Cells(drawRow, "A").Height / 2
    With ActiveSheet.Shapes.AddLine(stDate.Left, posY, edDate.Left + edDate.Width, posY).Line
        .ForeColor.RGB = arrowColor
        .Weight = 5
        .EndArrowheadStyle = msoArrowheadTriangle
    End With
 End Sub

 '//-------------------
 Function findDate(keyDate As Range, calDate As Range) As Range
 '//-------------------
 '//  日付検索関数
 '//-------------------
    Dim r As Range
    For Each r In calDate
        If r.Value2 = keyDate.Value2 Then
            Set findDate = r
            Exit Function
        End If
    Next
    Set findDate = Nothing
 End Function
 (Mook)
----
Mookさん

ありがとう御座います。
考えていた通りに矢印を書く事が出来ます。

とりあえずこのコードを使わせて頂いて、
時間がかかるでしょうが、内容を理解して、
それから例えば後で日付を変更した場合の
エラーメッセージとか、追加していきたいと思います。

本当にありがとう御座いました。
（ふみ）
----
 A7 の日付を変えたときに全体を再描画したいとか、
 いろいろ要望が出ると思うので、内容を理解されると後が楽かと思います。
 (Mook)
----
 そういえば仕様しっかり説明していませんでした。
 
 A7変更で全体再描写
 B12:E49の偶数行を変更すると再描写
 A7,B12:E49を右クリックでカレンダー表示
 ↑以外を選択するとカレンダーの非表示です。

 開始日が日程表より前でも、終了日が日程表にある場合は、矢印の始まりを●くして表示したい等
 自分用に手直ししたコードも出来ていますので（アイディア頂いて活用してます）ご連絡ください。

  （稲葉）2013/10/03(木曜日)　14:56
 
----
Mookさん、稲葉さん、色々とありがとう御座います。
内容を理解してから、使い勝手を良くしていこうと思います。

またアイデアを活用して頂いて嬉しいです。

この日程表以外にも、見積算出ツールとか、エクセルで色々なツールを作って
社内を驚かせて喜んでます＾＾
（ふみ）