『入力した値が同シート内で重複しない場合に警告音』（とり）

質問失礼致します。

もとからＤ列には多数の値が入力されておりＢ列に新しく値を入力した際、
Ｄ列に入力されている値と " 重複しない場合 " に警告音を出したいのです。

現状、重複に色がつくようにしており
色がつかなかった場合は重複なしと判断しているのですが、
作業中にＰＣ画面を見ているのでは効率が悪いため
音で判断をしたいです。

調べても重複する場合に警告という内容のものしか見つけられなかったため
ご教示いただけますと幸いです。



＜ 使用 Excel：Excel2013、使用 OS：Windows7 ＞
----
 入力規則で警告を出すようにしてはどうか？
 (警告時ダイアログ表示時には音も出るらしい。私の環境ではＰＣから音が出ないような設定になっているため未確認）
（ねむねむ） 2017/11/07(火) 16:03
----
とり　さん
こんばんは、
ねむねむ　さんご指摘の入力規則と併用されると効果的かも、です。

＞Ｄ列には多数の値が入力されておりＢ列に新しく値を入力、
が前程で
当該のシートのVBEに貼り付けてください。
参考まで。

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim B_flg As Boolean
  Dim ad As String
  Dim cnt As Long
  B_flg = True
  ad = Target.Address(False, False)
  If (Mid(ad, 1, 1) <> "B") Or (Selection.Count > 1) Or (IsEmpty(Range(ad).Value)) Then
    Exit Sub
  End If
  For cnt = 1 To Cells(Rows.Count, 4).End(xlUp).Row
    If Cells(cnt, 4).Value = Range(ad).Value Then
      B_flg = False
    End If
  Next cnt
  If B_flg Then
    Beep
  End If
End Sub
（隠居じーさん） 2017/11/07(火) 21:50
----
追記

（＾＾；

入力規則だけでも、
ねむねむ　さんご指摘通りダイアログも
音もかなりきれいなベル音が出ますよ。
マクロは必要ないかもです。

<(_ _)>

（隠居じーさん） 2017/11/07(火) 22:00
----
ねむねむ 様
隠居じーさん 様

ご教示ありがとうございます。
入力規則で確かに音が出たうえ、誤った入力を防ぐことができました。
難しそうだなと少し忌避していたのですが案外簡単に使えたので
ここでご教示いただけてよかったです。


VBAもシートに貼り付け使用してみたのですがＢ列へ入力毎に音が鳴ってしまいました。
（同シート内にＢ列入力時、隣のセルに日付を自動入力するVBAが入っていたのですが
　それが影響を与えてしまうことがあったりするのでしょうか。。？）

（とり） 2017/11/08(水) 15:58
----
とり　様へ

テストしましたが、Ｂ列に入力した値が

Ｄ列の数値と同じ数値であれば鳴りません。
Ｄ列の数値と違えば鳴ります。

尚、Ｂ列のみ確認しておりますのでＡ列の値は関係無いとは
思いますが、ソースが解らないので判断出来ません。

はずしておりましたら、申し訳ありません

<(_ _)>



（隠居じーさん） 2017/11/08(水) 16:32
----
隠居じーさん 様 


下記、ご教示頂いたVBAを組み込んだ際のソースです。

----

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Column = 3 Then
If Cells(Target.Row, 3).Value <> "" Then Status = Date Else Status = ""
If TypeName(Target.Value) <> "Variant()" Then Cells(Target.Row, 2).Value = Status Else _
For i = 0 To UBound(Target.Value) - 1: Cells(Target.Row + i, 2).Value = Status: Next
End If

  Dim B_flg As Boolean
  Dim ad As String
  Dim cnt As Long
  B_flg = True
  ad = Target.Address(False, False)
  If (Mid(ad, 1, 1) <> "B") Or (Selection.Count > 1) Or (IsEmpty(Range(ad).Value)) Then
    Exit Sub
  End If
  For cnt = 1 To Cells(Rows.Count, 4).End(xlUp).Row
    If Cells(cnt, 4).Value = Range(ad).Value Then
      B_flg = False
    End If
  Next cnt
  If B_flg Then
    Beep
  End If
End Sub

----

最近VBAを使い始めたのでそもそも組み込み方自体が
間違っているかもしれません＾＾； 
（とり） 2017/11/08(水) 17:11
----
とり　様
こんばんわ
テストしてみました。
Ｃ列に何か情報があればＢ列に何を入力しても
入力したＢ列のセルが日付情報に変換されてしまいます。
後、Ｃ列を更新（消す）するとハングアップしますよ。　（＾＾；

行頭にOption Explicitを指定して
変数の宣言とか
if構文は　End　IFで括られたほうがメンテはしやすいかもです。
で
結果Beep音が連発しているようです。
日付はＡ列にされて、Ｂ列は入力用にあけておかれた方がよいかと。
取り急ぎ、ご報告まで。

<(_ _)>

（隠居じーさん） 2017/11/08(水) 19:53
----
とり　様
こんばんわ
ハングアップは私の勘違いです。

失礼致しました。　m(__)m

Ubound(Target.Value)は
全列削除を指定した場合、最終行まで処理となり
時間がかかって、一時応答なし状態でした。


＞同シート内にＢ列入力時、隣のセルに日付を自動入力するVBA

の隣のセルがＡ列と仮定してですが。

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Status
  Dim i As Long
  If Target.Column = 2 Then
    If Cells(Target.Row, 2).Value <> "" Then
      Status = Date
    Else
      Status = ""
    End If
    If TypeName(Target.Value) <> "Variant()" Then
      Cells(Target.Row, 1).Value = Status
    Else
      For i = 0 To Cells(Rows.Count, 1).End(xlUp).Row
        Cells(Target.Row + i, 1).Value = Status
      Next
    End If
  End If
  '********************************************************
  Dim B_flg As Boolean
  Dim ad As String
  Dim cnt As Long
  B_flg = True
  ad = Target.Address(False, False)
  If (Mid(ad, 1, 1) <> "B") Or (Selection.Count > 1) Or (IsEmpty(Range(ad).Value)) Then
    Exit Sub
  End If
  For cnt = 1 To Cells(Rows.Count, 4).End(xlUp).Row
    If Cells(cnt, 4).Value = Range(ad).Value Then
      B_flg = False
    End If
  Next cnt
  If B_flg Then
    Beep
  End If
End Sub
で、どうでしょうか
参考まで
外してましたらすみません。

<(_ _)>

（隠居じーさん） 2017/11/08(水) 23:43
----
隠居じーさん　様

こんにちは

＞同シート内にＢ列入力時、隣のセルに日付を自動入力するVBA

の隣のセルは仰るとおりＡ列のことになります。
説明が足りず申し訳ございません。。


また、遅くまでご教示頂きありがとうございます。
本日は音の確認できる環境ではないため明日改めて確認いたします。

取り急ぎご連絡まで。


（とり） 2017/11/09(木) 13:51
----
とり　様
ご連絡、有難うございます。
修正版をUpいたします。
修正箇所
１．全範囲選択でDELETEをかけるとオーバーフローをエラー処理。
２．Ａ列の消去処理、途中は空白でＡ，Ｂ列、最終行付近に情報があった
　　場合時間がかかりすぎるので1000行以降はMSGを表示後、処理中断と
　　しました。後でＡ列全行選択で削除してください。
　　1000行以上ご必要な場合は追加の当該コードを削除してください
３．Ｂ列の行全て選択時のエラートラップ追加。
お試しを。

<(_ _)>


Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Status
  Dim i As Long
  On Error GoTo my_end
  If Target.Column = 2 Then
    If Cells(Target.Row, 2).Value <> "" Then
      Status = Date
    Else
      Status = ""
    End If
    If TypeName(Target.Value) <> "Variant()" Then
      Cells(Target.Row, 1).Value = Status
    Else
      For i = 0 To Cells(Rows.Count, 1).End(xlUp).Row
        If i > 1000 Then
          Call my_chk
          Exit Sub
        End If
        Cells(Target.Row + i, 1).Value = Status
        DoEvents
      Next
    End If
  End If
  '********************************************************
  Dim B_flg As Boolean
  Dim ad As String
  Dim cnt As Long
  B_flg = True
  ad = Target.Address(False, False)
'  MsgBox ad
  If (Mid(ad, 1, 1) <> "B") Or (Selection.Count > 1) Or _
     (IsEmpty(Range(ad).Value)) Or ad = "B:B" Then
  Exit Sub
  End If
  For cnt = 1 To Cells(Rows.Count, 4).End(xlUp).Row
    If cnt > 1000 Then
      Call my_chk
      Exit Sub
    End If
    If Cells(cnt, 4).Value = Range(ad).Value Then
      B_flg = False
    End If
  Next cnt
  If B_flg Then
    Beep
  End If
  Exit Sub
my_end:
MsgBox Err.Number & "error ^^:"
End Sub
Private Sub my_chk()
  MsgBox "A列の1000行以降に不審な情報があるようです。"
End Sub
追伸
もう少しお待ちになると。私の様なへぼコード（何とかうごくだけ(＾＾））
ではなく
ＶＢＡウイザードさまがたくさんおられますので、
もっと素晴らしい知識をお示し戴けるかもです　＾＾；

<(_ _)>

（隠居じーさん） 2017/11/09(木) 17:43
----
入力規則で解決したのに、なぜマクロなのかわかりませんが。
こんなことでしょうか？
 Option Explicit

 Private Sub Worksheet_Change(ByVal Target As Range)
        Dim rr As Range, r As Range
        Dim m, flg As Boolean
        
     Set rr = Intersect(Target, Columns("B"))    
    If rr Is Nothing Then Exit Sub
    
    Application.EnableEvents = False
    
    rr.Offset(, -1).ClearContents
    rr.Interior.ColorIndex = xlNone
    
    For Each r In rr
        If r.Value <> "" Then
            r.Offset(, -1).Value = Date
            m = Application.Match(r, Columns("D"), 0)
            If IsError(m) Then
                r.Interior.Color = vbRed
                flg = True
            End If
        End If
    Next
    
    If flg Then Beep
    
    Application.EnableEvents = True

 End Sub

（マナ） 2017/11/09(木) 21:21
----
マナ　様
おはようございます。試してみました。
視覚、聴覚、で確認でき。凄いですね。

＞入力規則で解決したのに、なぜマクロなのかわかりませんが。
私の場合は、下手の横好き、という事で

とても勉強になります。
ありがとうございました。

とり　様、割り込み、すみません

<(_ _)>
 
（隠居じーさん） 2017/11/10(金) 08:55
----
隠居じーさん　様
マナ　様

こんにちは。
いろいろご教示頂きありがとうございます。

シートに貼り付けて使用してみたのですが
何も反応しなかったです。
変数の宣言について知識が無いためそこが原因かなと思います。。
（勉強します）
教えてくださったのにすぐに活かす事ができず申し訳ないです。


＞入力規則で解決したのに、なぜマクロなのかわかりませんが。 
最低限欲しい機能が今回の件だったため、
今後機能を追加した際に今回マクロのことについて教わっておけば
何かしら活用できるのでは？という下心からです。


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

（とり） 2017/11/10(金) 15:59