[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『日程表に矢印を書きたい』（ふみ）
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)
書いて頂いたコードを走らせてみましたが、
残念ながら矢印を書く事が出来ません。
表の構成は、
[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)
日付の説明は間違えていました。申し訳有りません。
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)
構成は下記の様にしています。
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)
ありがとう御座います。
考えていた通りに矢印を書く事が出来ます。
とりあえずこのコードを使わせて頂いて、
時間がかかるでしょうが、内容を理解して、
それから例えば後で日付を変更した場合の
エラーメッセージとか、追加していきたいと思います。
本当にありがとう御座いました。
（ふみ）
A7 の日付を変えたときに全体を再描画したいとか、 いろいろ要望が出ると思うので、内容を理解されると後が楽かと思います。 (Mook)
そういえば仕様しっかり説明していませんでした。
A7変更で全体再描写 B12:E49の偶数行を変更すると再描写 A7,B12:E49を右クリックでカレンダー表示 ↑以外を選択するとカレンダーの非表示です。
開始日が日程表より前でも、終了日が日程表にある場合は、矢印の始まりを●くして表示したい等 自分用に手直ししたコードも出来ていますので（アイディア頂いて活用してます）ご連絡ください。
（稲葉）2013/10/03(木曜日) 14:56
またアイデアを活用して頂いて嬉しいです。
この日程表以外にも、見積算出ツールとか、エクセルで色々なツールを作って
社内を驚かせて喜んでます＾＾
（ふみ）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.