『セルに日付を入力すると入力された日に★マークが表示される』（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"　、つまりいつも「１行目？？」
 
 ちょっとわかりにくいかもしれないけど、たとえば F1 というと、我々は、エクセルシートの６番目の列の１行目のセルだと
 そう認識するね。でも、本当は、「シートのセル全体の中の」 F1 ということで、「」の中が省略されている。
 なので、F1 というのは　「指定された領域の」１行目の６列目。

 c.EntireRow という領域は、入力があった D列のセルの行全体。　その行全体.F1 が、その行のF列。
 その行全体.F3 だと、その行から２行下の行のF列ということになってしまう。

 なので

 c.EntireRow.Range("F3:NF3").ClearContents  ' <--クリア

 ではなく

 c.EntireRow.Range("F1:NF1").ClearContents  ' <--クリア

 (ぶらっと)
----
>>ぶらっとさん

迅速なご回答、ありがとうございます。
ご指摘の通り、修正したところ、クリアされました。

大変助かりました。
本当にありがとうございました。

m(_ _)m

更に追加になるのですが、

入力日を(10個位の)複数設定も可能でしょうか？
欲張りなことばかりで申し訳ありません。
----
 >入力日を(10個位の)複数設定も可能でしょうか？ 


 今のコードですでに、D6より下のD列であれば、どこに入っても（D1000000 に入っても）処理するようになっているけど？

 「複数設定」というのがよくわからないんだけど？

 追記）　もしかして、D列の１つのセルに 4/1,4/10,4/30 といったように入れたいということ？
 　　　　できないことはないけど、この場合、【年】がなくなってしまうので、実行時のシステム日付の年という扱いになるね。
 　　　　で、そうであれば、それより、D列〜M列あたりを日付入力欄にして、（だから F列以降は、うんと右にシフト）
 　　　　対応したほうがすっきりするけどね。

 (ぶらっと)
----
To ぶらっとさん

お疲れ様です。

確認しました。
素晴らしい作りです！

この度は、本当に勉強になりました。
ありがとうございました。

m(_ _)m
----
To　ぶらっとさん

お疲れ様です。

度々申し訳ありません。

D6に入力した日付を削除すると★マークは消えるのですが、
D7に入力した日付を削除しても★マークは消えません。

何か手立てはありますでしょうか？
おんぶに抱っこばかりで申し訳ありません。
----
To ぶらっとさん

お疲れ様です。

私の環境が不安定なだけでした。
お騒がせしました。

ありがとうございました。　m(_ _)m
----
 ↑　いやぁ、コードのチョンボだと思うよ？
 以下、メモってる間に、そちらのレスがはいったけど、そのままアップするね。

 指摘深謝！！　なぁるほど。チョンボだね。
 日付の入力は、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

 (ぶらっと)

----
To ぶらっとさん 

お疲れ様です。 

ご対応、ありがとうございます。
問題なく動作しました。
ありがとうございました。* 100　m(_ _)m
----
To ぶらっとさん

お疲れ様です。

発展系を教えてください。

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行目は ?

 (ぶらっと)
 
----
To ぶらっとさん

誤記です。

D3に4/1を入力　　　　　★表示
E3に4/3を入力します。　◎表示

3行目の列に　それぞれ、★と◎が表示されるようにしたいのですが…


----
 対象の列数が多ければループで回す手もあるけど、D列とE列、２つだけなので以下のようなべたべたのコードのほうが
 わかりやすいかな？

 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

 (ぶらっと)
----
To ぶらっとさん

おはようございます。

ご教授頂いたソースを利用したのですが、動きませんでした。

条件は、下記の通りです。
F2：1/1〜NF2:12/31

D3：4/10を入力
D3：4/11を入力

ご多忙とは存じますが、ご教授願えないでしょうか。
----
 いわれてみれば、日付入力が D3 と、「３行目」なので、従来の 「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

 (ぶらっと)
----
To ぶらっとさん

お疲れ様です。

説明不足が多々あり、申し訳ありませんでした。
正常動作しました。
VBAの超初心者の私には、難しいです。

本当にありがとうございました。　m(_ _)m
----
To ぶらっとさん 

お疲れ様です。

追加で教えてください。

★マークを記載したセルを塗りつぶしたいのですが、
上手くいきません。
ご教授願えないでしょうか。

----
 テストはしていないけど

 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 とか。

 (ぶらっと)
----
To ぶらっとさん 

お疲れ様です。 

迅速なご回答、ありがとうございます。
正常動作しました。 

ただ、土日の塗りつぶしもクリアされてしまい、
土日の塗りつぶしを元に戻す方法もありますか？
ご多忙とは存じますが、ご教授願えないでしょうか。 

----
 >ただ、土日の塗りつぶしもクリアされてしまい

 う〜ん、これは要件追加とか発展型といったものじゃなく、条件の後出し。

 >土日の塗りつぶしを元に戻す方法もありますか？

 そういう方法もあるし、背景色のクリアから土日を除くという方法もあるし、いかようにもできるけど
 たとえばＤ列やＥ列に、（間違い入力も含めて）土日の日付がはいったら、その該当セルには色をつける？
 それとも、土日色のままにしておく？　色をつけるとしたら、いったん色がついて、また日付がなおされたら
 その前に、土日のところについていた色を消した上で、土日色に戻す？

 というか、Ｄ列やＥ列に土日の日付が入ったらエラーにしたほうがいいのかな？

 土日の色を消さないということに前に、そのあたりをどうするか、考えて、教えてくれる？

 (ぶらっと)
----
To ぶらっとさん 

お疲れ様です。

確かに、ぶらっとさんのおっしゃる通り、Ｄ列やＥ列に土日の日付が入ったらエラーにしたほうがいいですね。


----
 ↑のコメントを読む前にメモしてアップして衝突。
 そのまま以下に。　エラーにはしないで、平気で（？）土曜日や日曜日のところに色を塗る。
 で、しまった、ということで、日付を直したら、間違って塗られた土曜日や日曜日のところは、元の色にもどる。
 （元の色というか、２行目の日付行に塗られているそれぞれの色に戻す）

 とりあえず試してみて。
 なお、前提として２行目の日付行にも、土、日　それぞれのセルに、それぞれの色がついているということにしている。
 （少なくとも、最初の土曜日と最初の日曜には色を付けておいてね）

 シートモジュールのコードをすべてリプレース。

 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日

 この２行は、いらなくなったんだけど、消し忘れで、そのままアップしてしまった。
 （あっても害にはならないけど、fd や td は GetInfo の中でセットするようにしているので）

 (ぶらっと)
----
To ぶらっとさん 

お疲れ様です。 

土日の塗りつぶしは消され無くなりました。
でも本日の塗りつぶしが消されちゃいます…
----
 >でも本日の塗りつぶしが消されちゃいます…


 ん？？　本日の塗りつぶしって何のこと？
 まだ、聞いていない色塗りが、他にもあるのかな？

 そのほかにも、記念日に色がついているのは消したくないとか、祝祭日があるとか？？？

 (ぶらっと)
----
 気を取り直し、想像をたくましくして。（これが最後になったらいいなぁ。。。）

 土日に限らず、２行目の日付欄にあらかじめ塗ってある色（何種類の色が登場してもＯＫ）を、入力行の該当列に反映。
 なので、最初の土日だけじゃなく、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
 
 (ぶらっと)
----
To ぶらっとさん 

お疲れ様です。 


迅速なご回答、ありがとうございます。 
正常動作しました。