[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『セルに日付を入力すると入力された日に★マークが表示される』(sonson)
E1に1月1日〜NE1に12月31日と入力してあります。
D3に日付を入力するとD3に入力された日付にあたる3列目に★マークが表示されるようにしたいのですが、教えてください。
3/26 3/27 3/28 3/29 3/30 3/31 4/1 4/2 4/3
開催日 (D3に日付を入力→)4/1 ★
開催案内 1ヶ月前 3/2
開催案内 1週間前 3/25
Excel2010
すなおに、 E3 : =IF($D3=E$1,"★","") で、これをNE3までフィルコピーして、そのまま下に必要なだけフィルコピー ?
(ぶらっと)
ぶらっとさん
ありがとうございます。
でも回答して頂いた内容だと、全てのセルに条件文を入力しなければなりません。
それに複数行必要なので、処理自体が重くなります。
VBAとかでできないでしょうか?
>VBAとかでできないでしょうか?
うん、そのほうがいいと思う。
シートモジュール(シートタブを右クリック、コードの表示で、でてくるところ)に以下を貼り付け。 なお、E1からNE1 まで、連続した日付がセットされているということを前提。 (とびとびの日付、たとえば1/1 の右が1/10とか、がセットされているということなら、すこしコードを直すけど)
Private Sub Worksheet_Change(ByVal Target As Range) Dim r As Range Dim c As Range Dim fd As Date Dim td As Date
Set r = Intersect(Target, Range("D3", Range("D" & Rows.Count).End(xlUp))) If r Is Nothing Then Exit Sub
Application.EnableEvents = False
fd = Range("E1").Value td = Range("NE1").Value
For Each c In r c.EntireRow.Range("E1:NE1").ClearContents If IsDate(c.Value) Then If c.Value >= fd And c.Value <= td Then c.EntireRow.Cells(c.Value - fd + 5).Value = "★" End If End If Next
Application.EnableEvents = True
End Sub
(ぶらっと)
ぶらっとさん
おはようございます。
教えていただいた通りに行ったところ、正常に動作しました。
ありがとうございます。
ついでと言ったらなんですが、
日を変更した際、既に書かれている★を削除する方法もご教授ねがえないでしょうか?
よろしくお願い致します。
>日を変更した際、既に書かれている★を削除する方法もご教授ねがえないでしょうか?
ん? そうしているつもりだけど? そうなっていない、前のものが残ったままということ?
(ぶらっと)
ぶらっとさん
お疲れ様です。
F3に1/1 〜 FN3に12/31
D6に日付を入力に変更しました。
前回教えて頂いた内容で、分かる範囲を修正して実行してみました。
日付を変更しても前回の★マークが残ったままです。
修正後
↓
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range ' <-- 入力日付 Dim c As Range ' <-- Dim fd As Date ' <--1月1日 Dim td As Date ' <--12月31日
Set r = Intersect(Target, Range("D6", Range("D" & Rows.Count).End(xlUp))) ' <-- 入力日付をセット If r Is Nothing Then Exit Sub
Application.EnableEvents = False
fd = Range("F3").Value ' <-- 1月1日 td = Range("NF3").Value ' <-- 12月31日
For Each c In r ' <--入力日になるまで繰り返す c.EntireRow.Range("F3:NF3").ClearContents ' <--クリア If IsDate(c.Value) Then ' <--日付が正しいかチェック If c.Value >= fd And c.Value <= td Then ' <-- c.EntireRow.Cells(c.Value - fd + 6).Value = "★" ' <-- End If End If Next
Application.EnableEvents = True
End Sub
なるほど。
元のコードで
c.EntireRow.Range("E1:NE1").ClearContents
こういうところがあったわけだね。で、E〜NE を F〜NF に変更したので、ここを修正。この目のつけどころは正解。 ただ、↑のコードをよくみてほしいんだけど、どの行であろうとも、"E1:NE1" 、つまりいつも「1行目??」
ちょっとわかりにくいかもしれないけど、たとえば F1 というと、我々は、エクセルシートの6番目の列の1行目のセルだと そう認識するね。でも、本当は、「シートのセル全体の中の」 F1 ということで、「」の中が省略されている。 なので、F1 というのは 「指定された領域の」1行目の6列目。
c.EntireRow という領域は、入力があった D列のセルの行全体。 その行全体.F1 が、その行のF列。 その行全体.F3 だと、その行から2行下の行のF列ということになってしまう。
なので
c.EntireRow.Range("F3:NF3").ClearContents ' <--クリア
ではなく
c.EntireRow.Range("F1:NF1").ClearContents ' <--クリア
(ぶらっと)
ぶらっとさん
迅速なご回答、ありがとうございます。
ご指摘の通り、修正したところ、クリアされました。
大変助かりました。
本当にありがとうございました。
m(_ _)m
更に追加になるのですが、
入力日を(10個位の)複数設定も可能でしょうか?
欲張りなことばかりで申し訳ありません。
>入力日を(10個位の)複数設定も可能でしょうか?
今のコードですでに、D6より下のD列であれば、どこに入っても(D1000000 に入っても)処理するようになっているけど?
「複数設定」というのがよくわからないんだけど?
追記) もしかして、D列の1つのセルに 4/1,4/10,4/30 といったように入れたいということ? できないことはないけど、この場合、【年】がなくなってしまうので、実行時のシステム日付の年という扱いになるね。 で、そうであれば、それより、D列〜M列あたりを日付入力欄にして、(だから F列以降は、うんと右にシフト) 対応したほうがすっきりするけどね。
(ぶらっと)
お疲れ様です。
確認しました。
素晴らしい作りです!
この度は、本当に勉強になりました。
ありがとうございました。
m(_ _)m
お疲れ様です。
度々申し訳ありません。
D6に入力した日付を削除すると★マークは消えるのですが、
D7に入力した日付を削除しても★マークは消えません。
何か手立てはありますでしょうか?
おんぶに抱っこばかりで申し訳ありません。
お疲れ様です。
私の環境が不安定なだけでした。
お騒がせしました。
ありがとうございました。 m(_ _)m
↑ いやぁ、コードのチョンボだと思うよ? 以下、メモってる間に、そちらのレスがはいったけど、そのままアップするね。
指摘深謝!! なぁるほど。チョンボだね。 日付の入力は、D列6行目以降ならどこでも対応。 クリアも下のほうに何か値があれば対応するんだけど、唯一、クリアしたD列のセルが、D列の最後の場合は 対象外とみなされてしまう。おそまつ。ペコリ!
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range ' <-- 入力日付 Dim c As Range ' <-- Dim fd As Date ' <--1月1日 Dim td As Date ' <--12月31日
Set r = Intersect(Target, Columns("D")) ' <-- 入力日付をセット If r Is Nothing Then Exit Sub
Application.EnableEvents = False
fd = Range("F3").Value ' <-- 1月1日 td = Range("NF3").Value ' <-- 12月31日
For Each c In r ' <--入力日になるまで繰り返す If c.Row >= 6 Then c.EntireRow.Range("F1:NF1").ClearContents ' <--クリア If IsDate(c.Value) Then ' <--日付が正しいかチェック If c.Value >= fd And c.Value <= td Then c.EntireRow.Cells(c.Value - fd + 6).Value = "★" End If End If End If Next
Application.EnableEvents = True
End Sub
(ぶらっと)
お疲れ様です。
ご対応、ありがとうございます。
問題なく動作しました。
ありがとうございました。* 100 m(_ _)m
お疲れ様です。
発展系を教えてください。
D3に4/1を入力すると★マークが表示され、
D4に4/3を入力すると◎マークが表示されるように
したいのですが、教えて頂けないでしょうか?
よろしくお願い致します。
3/28 3/29 3/30 3/31 4/1 4/2 4/3
D3に4/1 D4に4/3 ★ ◎
ん? D4 に入力したものの ◎ を 3行目にセット? それとも、素直に、D4 の場合は、4行目の該当のところに ◎ ?
後者だとしたら、5行目は? △ ? 6行目は ?
(ぶらっと)
誤記です。
D3に4/1を入力 ★表示
E3に4/3を入力します。 ◎表示
3行目の列に それぞれ、★と◎が表示されるようにしたいのですが…
対象の列数が多ければループで回す手もあるけど、D列とE列、2つだけなので以下のようなべたべたのコードのほうが わかりやすいかな?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range ' <-- 入力日付 Dim c As Range ' <-- Dim fd As Date ' <--1月1日 Dim td As Date ' <--12月31日 Dim dt1 As Variant Dim dt2 As Variant
Set r = Intersect(Target, Columns("D:E")) ' <-- 入力日付をセット If r Is Nothing Then Exit Sub
Application.EnableEvents = False
fd = Range("F3").Value ' <-- 1月1日 td = Range("NF3").Value ' <-- 12月31日
For Each c In r.Rows ' <--入力日になるまで繰り返す If c.Row >= 6 Then c.EntireRow.Range("F1:NF1").ClearContents ' <--クリア dt1 = c.EntireRow.Range("D1").Value dt2 = c.EntireRow.Range("E1").Value If IsDate(dt1) Then ' <--日付が正しいかチェック If dt1 >= fd And dt1 <= td Then c.EntireRow.Cells(dt1 - fd + 6).Value = "★" End If End If If IsDate(dt2) Then ' <--日付が正しいかチェック If dt2 >= fd And dt2 <= td Then c.EntireRow.Cells(dt2 - fd + 6).Value = "◎" End If End If
End If Next
Application.EnableEvents = True
End Sub
(ぶらっと)
おはようございます。
ご教授頂いたソースを利用したのですが、動きませんでした。
条件は、下記の通りです。
F2:1/1〜NF2:12/31
D3:4/10を入力
D3:4/11を入力
ご多忙とは存じますが、ご教授願えないでしょうか。
いわれてみれば、日付入力が D3 と、「3行目」なので、従来の 「N3:NF3」の日付欄は、少なくとも 3行目ではないんだね? (でも、レイアウト変更したということを書いてくれると、スムーズだったんだけどね)
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range ' <-- 入力日付 Dim c As Range ' <-- Dim fd As Date ' <--1月1日 Dim td As Date ' <--12月31日 Dim dt1 As Variant Dim dt2 As Variant
Set r = Intersect(Target, Columns("D:E")) ' <-- 入力日付をセット If r Is Nothing Then Exit Sub
Application.EnableEvents = False
fd = Range("F2").Value ' <-- 1月1日 '■変更 td = Range("NF2").Value ' <-- 12月31日 '■変更
For Each c In r.Rows ' <--入力日になるまで繰り返す If c.Row >= 3 Then '■変更 c.EntireRow.Range("F1:NF1").ClearContents ' <--クリア dt1 = c.EntireRow.Range("D1").Value dt2 = c.EntireRow.Range("E1").Value If IsDate(dt1) Then ' <--日付が正しいかチェック If dt1 >= fd And dt1 <= td Then c.EntireRow.Cells(dt1 - fd + 6).Value = "★" End If End If If IsDate(dt2) Then ' <--日付が正しいかチェック If dt2 >= fd And dt2 <= td Then c.EntireRow.Cells(dt2 - fd + 6).Value = "◎" End If End If End If Next
Application.EnableEvents = True
End Sub
(ぶらっと)
お疲れ様です。
説明不足が多々あり、申し訳ありませんでした。
正常動作しました。
VBAの超初心者の私には、難しいです。
本当にありがとうございました。 m(_ _)m
お疲れ様です。
追加で教えてください。
★マークを記載したセルを塗りつぶしたいのですが、
上手くいきません。
ご教授願えないでしょうか。
テストはしていないけど
c.EntireRow.Range("F1:NF1").ClearContents ' <--クリア
この下に
c.EntireRow.Range("F1:NF1").Interior.ColorIndex = xlNone
また、
c.EntireRow.Cells(dt1 - fd + 6).Value = "★"
この下に
c.EntireRow.Cells(dt1 - fd + 6).Interior.Color = vbYellow
追記) ◎ のところにも色を塗るなら、◎のところのコードの下にも
c.EntireRow.Cells(dt2 - fd + 6).).Interior.Color = vbCyan とか。
(ぶらっと)
お疲れ様です。
迅速なご回答、ありがとうございます。
正常動作しました。
ただ、土日の塗りつぶしもクリアされてしまい、
土日の塗りつぶしを元に戻す方法もありますか?
ご多忙とは存じますが、ご教授願えないでしょうか。
>ただ、土日の塗りつぶしもクリアされてしまい
う〜ん、これは要件追加とか発展型といったものじゃなく、条件の後出し。
>土日の塗りつぶしを元に戻す方法もありますか?
そういう方法もあるし、背景色のクリアから土日を除くという方法もあるし、いかようにもできるけど たとえばD列やE列に、(間違い入力も含めて)土日の日付がはいったら、その該当セルには色をつける? それとも、土日色のままにしておく? 色をつけるとしたら、いったん色がついて、また日付がなおされたら その前に、土日のところについていた色を消した上で、土日色に戻す?
というか、D列やE列に土日の日付が入ったらエラーにしたほうがいいのかな?
土日の色を消さないということに前に、そのあたりをどうするか、考えて、教えてくれる?
(ぶらっと)
お疲れ様です。
確かに、ぶらっとさんのおっしゃる通り、D列やE列に土日の日付が入ったらエラーにしたほうがいいですね。
↑のコメントを読む前にメモしてアップして衝突。 そのまま以下に。 エラーにはしないで、平気で(?)土曜日や日曜日のところに色を塗る。 で、しまった、ということで、日付を直したら、間違って塗られた土曜日や日曜日のところは、元の色にもどる。 (元の色というか、2行目の日付行に塗られているそれぞれの色に戻す)
とりあえず試してみて。 なお、前提として2行目の日付行にも、土、日 それぞれのセルに、それぞれの色がついているということにしている。 (少なくとも、最初の土曜日と最初の日曜には色を付けておいてね)
シートモジュールのコードをすべてリプレース。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range ' <-- 入力日付 Dim c As Range ' <-- Dim fd As Date ' <--1月1日 Dim td As Date ' <--12月31日 Dim dt1 As Variant Dim dt2 As Variant Dim satColor As Long Dim sunColor As Long Dim satR As Range Dim sunR As Range
Set r = Intersect(Target, Columns("D:E")) ' <-- 入力日付をセット If r Is Nothing Then Exit Sub
Application.EnableEvents = False
GetInfo Range("F2:NF2"), fd, td, satR, satColor, vbSaturday GetInfo Range("F2:NF2"), fd, td, sunR, sunColor, vbSunday
fd = Range("F2").Value ' <-- 1月1日 td = Range("NF2").Value ' <-- 12月31日
For Each c In r.Rows ' <--入力日になるまで繰り返す If c.Row >= 3 Then c.EntireRow.Range("F1:NF1").ClearContents ' <--クリア c.EntireRow.Range("F1:NF1").Interior.ColorIndex = xlNone
'土日の色を復元 Intersect(c.EntireRow.Range("A1:NF1"), satR).Interior.Color = satColor Intersect(c.EntireRow.Range("A1:NF1"), sunR).Interior.Color = sunColor
dt1 = c.EntireRow.Range("D1").Value dt2 = c.EntireRow.Range("E1").Value If IsDate(dt1) Then ' <--日付が正しいかチェック If dt1 >= fd And dt1 <= td Then c.EntireRow.Cells(dt1 - fd + 6).Value = "★" c.EntireRow.Cells(dt1 - fd + 6).Interior.Color = vbYellow End If End If If IsDate(dt2) Then ' <--日付が正しいかチェック If dt2 >= fd And dt2 <= td Then c.EntireRow.Cells(dt2 - fd + 6).Value = "◎" c.EntireRow.Cells(dt2 - fd + 6).Interior.Color = vbCyan End If End If End If Next
Application.EnableEvents = True
End Sub
Private Sub GetInfo(r As Range, fd As Date, td As Date, dayR As Range, dayColor As Long, func As VbDayOfWeek) Dim c As Range Dim fCol As Long Dim tCol As Long Dim x As Long Dim i As Long
fd = r.Cells(1).Value td = r.Cells(r.Count).Value
fCol = r.Cells(1).Column tCol = r.Cells(r.Count).Column
x = ((func + 7) - Weekday(fd)) Mod 7
dayColor = r.Cells(1).Offset(, x).Interior.Color
Set dayR = Nothing
For i = fCol To tCol Step 7 If dayR Is Nothing Then Set dayR = Columns(i + x) Else Set dayR = Union(dayR, Columns(i + x)) End If Next
End Sub
(ぶらっと)
↑
fd = Range("F2").Value ' <-- 1月1日 td = Range("NF2").Value ' <-- 12月31日
この2行は、いらなくなったんだけど、消し忘れで、そのままアップしてしまった。 (あっても害にはならないけど、fd や td は GetInfo の中でセットするようにしているので)
(ぶらっと)
お疲れ様です。
土日の塗りつぶしは消され無くなりました。
でも本日の塗りつぶしが消されちゃいます…
>でも本日の塗りつぶしが消されちゃいます…
ん?? 本日の塗りつぶしって何のこと? まだ、聞いていない色塗りが、他にもあるのかな?
そのほかにも、記念日に色がついているのは消したくないとか、祝祭日があるとか???
(ぶらっと)
気を取り直し、想像をたくましくして。(これが最後になったらいいなぁ。。。)
土日に限らず、2行目の日付欄にあらかじめ塗ってある色(何種類の色が登場してもOK)を、入力行の該当列に反映。 なので、最初の土日だけじゃなく、F2〜NF2 まで、必要なセルには、必ず、それぞれに適した色が塗られていること。 (会社の創立記念日で休みの日とか、この仕事をしない日とか、好きなように)
シートモジュール全てリバイス。(GetInfo プロシジャは廃止)
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range ' <-- 入力日付 Dim c As Range ' <-- Dim fd As Date ' <--1月1日 Dim td As Date ' <--12月31日 Dim dt1 As Variant Dim dt2 As Variant Dim colorV() As Long Dim k As Long Dim i As Long
Set r = Intersect(Target, Columns("D:E")) ' <-- 入力日付をセット If r Is Nothing Then Exit Sub
Application.EnableEvents = False
fd = Range("F2").Value ' <-- 1月1日 td = Range("NF2").Value ' <-- 12月31日
With Range("F2:NF2") ReDim colorV(1 To .Columns.Count, 1 To 2) For Each c In .Cells If c.Interior.ColorIndex <> xlNone Then k = k + 1 colorV(k, 1) = c.Column colorV(k, 2) = c.Interior.Color End If Next End With
For Each c In r.Rows ' <--入力日になるまで繰り返す If c.Row >= 3 Then c.EntireRow.Range("F1:NF1").ClearContents ' <--クリア c.EntireRow.Range("F1:NF1").Interior.ColorIndex = xlNone
'あらかじめ塗られていた列の色を復元 For i = 1 To k c.EntireRow.Columns(colorV(i, 1)).Interior.Color = colorV(i, 2) Next
dt1 = c.EntireRow.Range("D1").Value dt2 = c.EntireRow.Range("E1").Value If IsDate(dt1) Then ' <--日付が正しいかチェック If dt1 >= fd And dt1 <= td Then c.EntireRow.Cells(dt1 - fd + 6).Value = "★" c.EntireRow.Cells(dt1 - fd + 6).Interior.Color = vbYellow End If End If If IsDate(dt2) Then ' <--日付が正しいかチェック If dt2 >= fd And dt2 <= td Then c.EntireRow.Cells(dt2 - fd + 6).Value = "◎" c.EntireRow.Cells(dt2 - fd + 6).Interior.Color = vbCyan End If End If End If Next
Application.EnableEvents = True
End Sub
(ぶらっと)
お疲れ様です。
迅速なご回答、ありがとうございます。
正常動作しました。
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.