VBAのシートイベントで教えてください

質問

シートのN4以下で、既に同じ番号があれば「既に同じ番号があります」
と表示するようにしたく、下のように書きましたが、肝心な部分
の、どのように同じ番号をみつけるようにすのかわかりませんでした。
教えていただけないでしょうか。宜しくお願いします。

Private Sub worksheet_change(ByVal target As Range)
Dim 範囲左 As Integer
Dim 範囲右 As Integer
Dim 範囲上 As Integer

範囲左 = 1
範囲右 = 16
範囲上 = 4

With target
'if　'指定した範囲の列Nに既に同じ番号や文字列があれば
MsgBox "既に同じ番号があります。"
End If
End With

End Sub

回答No.4

mitarashi · ベストアンサー

A No.1です。既にA No.3の方が述べられていますが、ご指名もいただいているので、遅ればせながら回答させていただきます。
For Each myCell In Sheets(1).Cells
If myCell.Address <> target.Address Then
If target.Value = myCell.Value Then
処理
Exit Sub
End If
これだと、ほとんど全てのセルに対して、アドレスのチェックと、値のチェックを行っています。値が同じ時だけ、アドレスのチェックをすれば、チェック回数は、約1/2になります。
加えて、No.3の方のご指摘通り、Sheets(1).UsedRange.cellsにすれば、チェック対象は格段に減ります。
それでも、遅ければA No.1の、Microsoft製のfindが優秀なアルゴリズムか否か試してみてはいかがですか。

お礼

ご回答ありがとうございました。
なかなかうまくいきません。。。
少し時間をかけて勉強してみようと思います。
お付き合いありがとうございました。

回答No.3

izmlz

いまいち、実際におやりになりたいことがよくわかっていないので、ご希望のものではないかも知れませんが．．．

　↓はN4：N65536にデータを入力した際に、N列に入力されているデータと重複している場合、メッセージを表示させるものです。

Private Sub Worksheet_Change(ByVal Target As Range)
　Dim Rng As Range
　Dim InputRng As Range

　Set Rng = Columns("N:N") '重複チェックする範囲を指定
　Set InputRng = Range("N4:N65536") '入力する際に重複チェックしたい範囲を指定

　If Intersect(Target, InputRng) Is Nothing Or Target.Count > 1 Then Exit Sub
　With Application.WorksheetFunction
　　If .CountIf(Rng, Target.Value) > 1 Then
　　　MsgBox "この番号は既に存在しています。", vbOKOnly + vbExclamation
　　End If
　End With
End Sub

＞無理のあるコードなのでしょうか。

気のついたところを何点か、指摘させていただくと、

＞For Each myCell In Sheets(1).Cells

　「Sheets(1).Cells」とありますが、N列のデータとの重複チェックではなくて当該シートの全データとの重複チェックなのでしょうか？もし、そうだとしても「Sheets(1).Cells」とするのではなく、「Sheets(1).UsedRange」といったようにするのが良いと思います。ついでにいうと、「Sheets(1).UsedRange」よりも「Worksheets(1).UsedRange」の方が良いかも。

　それから、For Each ～ Nextも良いですが、この場合には提示したマクロのようにワークシート関数のCOUNTIFを使う方が効率が良いんじゃないかと思いいます。

＞If .Column >= 範囲左 And .Column <= 範囲右 _
＞And .Row >= 範囲上 Then

　行や列を変数にすることもありますが、それはその方が処理がしやすい場合に限りそうするべきじゃないかと思います。そうでなければ、可読性が格段に良いので、私の提示したコードのように、「Set InputRng = Range("N4:N65536")」といった感じでセル範囲をセットする方が良いと思います。

回答No.2

okormazd

ただ、それだけでよければ、N列のデータ範囲に未入力セルがないとして、

Private Sub Worksheet_Change(ByVal Target As Range)

With Sheets(1)
r = 4
ndat = .Cells(r, 14)　'N4
While ndat <> ""
If Target <> ndat Then
r = r + 1
ndat = .Cells(r, 14)
Else
MsgBox "既に同じ番号があります。"
Exit Sub
End If
Wend
End With

End Sub

回答No.1

mitarashi

XL2000のVBEのヘルプから、findの使用例です。CopyRight Microsoft...
With Worksheets(1).Range("a1:a500")
'検索範囲の指定の仕方は、ここで分かりますね。
Set c = .Find(2, lookin:=xlValues)
'この例では、指定範囲に2が見つからないと、cはNothingになります。
'下記は、複数存在する全てを拾っていますので、省略可です。
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Interior.Pattern = xlPatternGray50
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With

お礼

mitarashiさんこんにちは。いつもご回答見させていただいております。ご回答いただいていることも知らず、自分で試行錯誤していました。アドバイスいただいておいて、
自分の作ったコード(といってもネットで参考にしたものですが・・・)
のことを聞くのは恐縮ですが、下のようにつくりました。
一応・・・動くのですが、パソコンの性能のせいか、
続けて入力すると砂時計が出て、何分経っても戻らず、Escなど
押してもどうしようもなくなるときがあります。
無理のあるコードなのでしょうか。

Private Sub worksheet_change(ByVal target As Range)
Dim 範囲左 As Integer
Dim 範囲右 As Integer
Dim 範囲上 As Integer
Dim myCell As Range

範囲左 = 14
範囲右 = 14
範囲上 = 4

With target
If .Column >= 範囲左 And .Column <= 範囲右 _
And .Row >= 範囲上 Then

For Each myCell In Sheets(1).Cells
If myCell.Address <> target.Address Then
If target.Value = myCell.Value Then
MsgBox "この番号は既に存在しています。", vbOKOnly + vbExclamation
Exit Sub
End If
End If
Next

End If
End With

End Sub