Results of 1 - 1 of about 1240 for カレンダー (0.001 sec.)
- [[20131001101322]]
- #score: 6127
- @digest: 0eecc15cc5ff4789b5514bfb4861b9ab
- @id: 63536
- @mdate: 2013-10-03T07:49:14Z
- @size: 29640
- @type: text/plain
- #keywords: calendar1 (113250), finddate (71599), dtcell (56447), rngend (48742), rngstart (45251), eddate (43324), ermsg (37921), 矢印 (21481), 程表 (19197), 日程 (18132), value2 (17503), vbnewline (15014), カレ (13547), 始日 (13497), 工程 (12187), 了日 (9071), visible (8600), レン (8433), 開始 (8044), ンダ (7435), 稲葉 (7076), activecell (7014), ダー (6888), 計画 (6245), activesheet (5861), intersect (5451), 日[ (5364), b12 (5162), 終了 (4777), 実績 (4616), nothing (3870), 日付 (3748)
- 『日程表に矢印を書きたい』（ふみ）
Windows XP,Excel2007を使用しています。 日程表の開始日付をカレンダーから選択し（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 次に確認です。 1、A7が日程表の開始日 2、B12が工程の開始日 3、C12が工程の終了日 1＜2の場合、どうしますか? 3＜2の場合、どうしますか? 表のイメージは以下の感じですか? [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] で、12行目から43行目まで、2セルずつを使って16項目の工程の 日付を計画と実績でカレンダーコントロールから入力し、 計画と実績の矢印の色を変えて確認出来る様にしようと思っています。 12行目の計画が12行目の矢印、12行目の実績が13行目の矢印、 で、42行目の計画が42行目の矢印、実績が43行目の矢印です。 カレンダーコントロールはクリックしたら消える、 指定セル以外をクリックした時も消える様に考えています。 今は同じセルをクリックする時は、一旦他のセルをクリックしてからしか カレンダーが現れないので、改善したいと思っています。 日程表開始日より以前の日付を入力しようとした時や、 工程開始日より以前の日付を工程終了日に入力しようとした時は エラーメッセージで入力出来ない様にしようと思っています。 稲葉さんと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さんのほうも問題ありませんでした。 1.11行目にある日付は、日付型のデータですか?文字列型ですか? 2.1.の日付は例えば 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 を貼りつけましたが、状況は変わりません。 11行目はごめんなさい、曜日を表示させています。 10行目が日付ですが、先頭の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を インストールしています。 カレンダーコントロールはアクセスの物を使用していると思うので、 この差でしょうか? （初心者改め、ふみ） ---- あ もしかしてセルの結合してませんか? ＞で、12行目から43行目まで、2セルずつを使って16項目の工程の その場合、 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 ---- もし、セルの結合をしているのであれば私のは動きません。 開始と終了が2セットある想定で作ってしまっていますので。 カレンダーだけは出ると思いますが。 (Mook) ---- 稲葉さん '//日付の検索 tbl = Range("F11:CS11").Value2 は気付いていたので10に変えて実行しました。 矢印は書ける様になりました。 ただ、カレンダーが実績の方で出ず、A7で出しても 実績のセルをクリックすると消えてしまうので 入力出来ません。 今から上のセル結合部分を修正してみます。 （初心者改め、ふみ） Mookさん 稲葉さんのアドバイスで書き変えてみます。 （ふみ） ---- ん? 結合している、でいいのかな? あとこちらでは実績のところも「右クリック」でちゃんと出るんだけど、 以下の条件に当てはまってる? 1.セルの結合は行・列方向共に2セル以内（3セル以上を結合していない） 2.結合されたセルの左上のセル（例えばA2:B3の結合なら、A2のセル）は必ず偶数行にある 3.あたりまえだけど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 ---- 稲葉さん 助言、ありがとう御座います。 言い訳になりますが、業務の合間を縫って作業しているので、 正直コードを理解したり調べたり、全然出来ていません。 どこか時間が出来た時に、教えて頂いたステップ実行とか 勉強したいです。 今はNETで参考になりそうなコードを見つけて 貼り合わせているだけなので、 基礎から勉強したいです。 ありがとう御座いました。 また、助けて下さい。 （ふみ） ---- ニックネーム対応頂きありがとうございました。 こちらも気持ちよく対応ができます。 私の当初の想定は下記のようなものなので、セルの結合や日付の扱いが異なる場合は 構成を再度説明ください。 [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まで2セルずつ結合させています。 これでおわかりになるでしょうか? 不明なところがあれば御指摘下さい。 [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] ----→ （ふみ） ---- だいぶ想定と違っていましたねw。 とりあえず、上記に合わせて修正しました。あちこち変わったので全体を再掲します。 '//------------------- 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さん、稲葉さん、色々とありがとう御座います。 内容を理解してから、使い勝手を良くしていこうと思います。 またアイデアを活用して頂いて嬉しいです。 この日程表以外にも、見積算出ツールとか、エクセルで色々なツールを作って 社内を驚かせて喜んでます^^ （ふみ）... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/201310/20131001101322.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97012 documents and 608132 words.
訪問者：