セル入力時、重複を防ぐ方法を教えて頂きたい

質問

Bookには一か月分のシート（9.1　9.2　・・・)が存在します。表はB4：AY43の大きさで、各シート共通で行15行目と34行目に「10桁の受注番号」を入力すのですが、この「受注番号」は絶対重複してはいけないコードになっています。当該各セルに受注番号を入力した時に、同シート及び他のシートに同じ番号が存在しないか判別し、存在しなければそのまま入力し、重複している時はメッセージで警告し入力した番号を一旦クリアーするにはどのようにすればよいでしょうか。宜しくお願い致します。

回答No.6

fujillin · ベストアンサー

イベント処理で行いたいとのことですので、各シートにコードを記載しなければなりませんが、処理内容が同じなので一つにまとめて見ました。
◆以下を標準モジュールに置いておきます。
Sub Code_Check(s_ad As String)
Dim st As Worksheet, rng As Range, flag As Boolean
Dim i As Long, s, c_in, c_cmp
Set rng = ActiveSheet.Range(s_ad)
If rng.Value = "" Then Exit Sub
c_in = Array("A1", "A2", "A3")　　　'//処理対照セル名を列記（入力セル）
c_cmp = Array("B1", "B2", "B3") 　 '//比較対照セル名を列記（参照セル）
flag = True
i = LBound(c_in)
'//処理対照セルかどうかを判定
While flag And (i <= UBound(c_in))
　If rng.Address = Range(c_in(i)).Address Then flag = False
　i = i + 1
Wend
If flag Then Exit Sub
'//ブック内の全シートについて比較
For Each st In Worksheets
　For Each s In c_cmp
　　If st.Range(s).Value = rng.Value Then
　　　If (st.Name <> ActiveSheet.Name) Or (st.Range(s).Address <> rng.Address) Then
　　　　MsgBox ("同じコードがすでにあります")
　　　　Exit Sub
　　　End If
　　End If
　Next s
Next st
End Sub

◆各月のシートには、以下の最小限のコードを記載しておきます。
Private Sub Worksheet_Change(ByVal Target As Range)
　Code_Check (Target.Address)
End Sub

◆各月のシートは同じ構成と仮定しています。準備として
・入力をチェックすべきセルをサンプルのように列記しておきます。（例ではA1、A2、A3セル）
・比較するべきセルの範囲を列記しておきます。（例ではB1、B2、B3セル）

重複は絶対不可とのことなので、どのシートであれ同じ番号があればメッセージがでます。
（処理対象と比較対照が重複している場合、自分自身が引っかかってしまいますので、その場合のみ許可するようにしています。）
ロジックは単純なので、違う点があれば、適宜修正してご使用ください。

お礼

御礼が遅れましたが、貴重なご意見誠にありがとうございます。非常に参考になります。色々自分なりに工夫して使用させていただきます。本当にありがとうございました。

回答No.7

mitarashi

素朴な疑問ですが、ユニークな受注番号を自動で生成する様にしてはいけないのでしょうか？何かルールがあって受注番号を決めるのでしょうが、それを自動化してしまえば、毎回重複チェックする必要は無くなると思いますがいかがですか。
一人での運用なら、ワークシートのどこかに最後の受注番号を記録しておけば良いでしょう。複数人での運用なら、参考URLをご覧下さい。

参考URL：

http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110_070.html

回答No.5

imogasi

入力するセル範囲の（列、行）と
重複をチェックする範囲（シート、行、列の範囲）はどうなっているか、具体的に書いてない質問ではないですか。
こういうのははっきり書くこと。
１シート全体や、複数シートでそういうことをしたければ、それなりの「受注番号」を１列ナリに集める仕組みが必要で、大掛かりになるように思う。
まあアクセスのＳＱＬでも使う世界かと思う。
それにＶＢＡでの処理を希望らしいが、質問には書いてないですね。
それなら課題丸投げですよ。
エクセルは他シートまで対象に何かをするのは苦手で、そうそう自由にはならないから、表設計から考えておく必要がある。

回答No.4

pkh4989

受注番号入力セルが一定でないと、いちいち比較するしかありません。
統合セルが D15：I15、J15:O15 の場合は
　　　　　 4　　　　 10

　　If Target.Column = 4 or _
　　　 Target.Column = 10 Then

のようにいちいち比較するしかありません。
なので、入力シートを一定に入力出来るように(統合なし)直すか、今のマクロを元に
研究して、修正してみてください。

お礼

貴重な情報を誠にありがとうございました。もっとＶＢＡを勉強してこれからも頑張りたいと思います。言葉足らずの説明大変失礼致しました。ありがとうございました。

回答No.3

pkh4989

Const wCol　　　As Integer = 3
→受注番号が入力されているカラムが、例えば「C」カラムだと「3」になります。
　A　B　C　D　E・・・・
　1　2　3　4　5・・・・

マクロは、各シートに貼り付ける必要があります。
最初は、１日目のシートにマクロを貼り付けた後に、そのままそのシートをコピーして２日目以降のシート
を作成すればいいと思います。
※貼り付け方法
シート名をマウス右クリックして「コードの表示」を選択→白いマクロシートが表示されるので、そのシートへ
マクロを貼り付けてください。

※今日は１９日なので、とりあえず、１９日のシートへ貼り付けて試してみてください。
　受注番号が入力されているカラムが合わないと反応しません。

補足

ありがとうございます。何列目のことですね^^;　カラムが複数の場合はどのように記述すればいいのでしょうか？因みに当セルはD15：I15　、　J15:O15　、のようにセルが統合されていて該当セルは８セルとなり、15行目と34行目を合わせると16セルになります。ご教授の程宜しくお願い致します。

回答No.2

pkh4989

以下のマクロで試してみてください。
全シートの重複チェック(Max 31シート)で、少々遅くなる可能性があります。

Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim curRow
　　Dim wR　　　　　As Integer
　　Dim ErFlg　　　 As Boolean
　　Const wCol　　　As Integer = 3　　　　　'←受注番号が入力さているカラム(変更して下さいね)
　　Dim wShtNm　　　As String
　　'
　　wShtNm = ActiveSheet.Name
　　If Target.Column = wCol Then
　　　　If Not IsEmpty(Target.Value) Then
　　　　　　If Target.Row >= 15 And _
　　　　　　　 Target.Row <= 34 Then
　　　　　　　　'
　　　　　　　　ErFlg = False
　　　　　　　　For wR = 15 To 34
　　　　　　　　　　If wR <> Target.Row Then
　　　　　　　　　　　　'入力行以外
　　　　　　　　　　　　If Cells(wR, wCol).Value <> "" Then
　　　　　　　　　　　　　　If Cells(wR, wCol).Value = Target.Value Then
　　　　　　　　　　　　　　　　MsgBox "重複エラー"
　　　　　　　　　　　　　　　　Application.Undo
　　　　　　　　　　　　　　　　Cells(Target.Row, wCol).Select
　　　　　　　　　　　　　　　　ErFlg = True
　　　　　　　　　　　　　　　　Exit For
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　End If
　　　　　　　　　　End If
　　　　　　　　Next
　　　　　　　　'
　　　　　　　　If ErFlg = False Then
　　　　　　　　　　'他のシートの重複チェック
　　　　　　　　　　If Chk_SameString(Target.Value, wCol, wShtNm) Then
　　　　　　　　　　　　MsgBox "重複エラー"
　　　　　　　　　　　　Application.Undo
　　　　　　　　　　　　Cells(Target.Row, wCol).Select
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　End If
　　　　End If
　　End If
End Sub
'他のシートの重複チェック
'セルをチェックすると遅くなるので、ワークメモリチェックしています
Function Chk_SameString(wStr As String, wCol As Integer, wShtNm As String) As Boolean
　　Dim c
　　Dim wI　　　　　As Integer
　　Dim wBuf　　　　As Variant
　　'
　　Chk_SameString = False
　　For Each c In Worksheets
　　　　If c.Name <> wShtNm Then
　　　　　　wBuf = Worksheets(c.Name).Range("A1:AY43")
　　　　　　For wI = 15 To 34
　　　　　　　　If wBuf(wI, wCol) = wStr Then
　　　　　　　　　　Chk_SameString = True
　　　　　　　　　　Exit Function
　　　　　　　　End If
　　　　　　Next
　　　　End If
　　Next
End Function

補足

Const wCol　　　As Integer = 3　　　　　'←受注番号が入力さているカラム(変更して下さいね)・・・の意味を教えていただけませんか。すいません素人なもので^^;　当コードをシートに貼り付けたのですが今のところ反応しません。宜しくお願い致します。

回答No.1

mu2011

次の方法は如何でしょうか。
（１）Ｂｏｏｋに受注番号リストの専用シートを作成
　　A1にシート名の固定文字列（仮に月「9」）を入力、各シートの入力セルはB15とB34としています。
　　B1に=INDIRECT(A1&"."&ROW(A1)&"!B5")としてした方向に31日分コピー
　　同様にC1に=INDIRECT(A1&"."&ROW(A1)&"!B34")としてした方向に31日分コピー
（２）B1:C31範囲を選択→名前ボックス（数式バーの左側枠）に任意名（仮に受注番号）を入力
（３）シートのB5,B34入力対象セルを選択→データ→入力規則→「ユーザ設定」を選択、数式欄に=COUNTIF(受注番号,B5)<2→ＯＫ

お礼

VBAでは難しいようでしたので貴殿の方法にて専用シートを作成し既存の入力規則を置き換えることで成功しました。誠にありがとうございました。

補足

早速のご返答ありがとうございます。回答方法参考にさせて頂きますが、出来ればVBAにて「Private Sub Worksheet_Change(ByVal Target As Range)」で方法があればいいのですが・・・言い忘れましたが、というのも当該セルには既に「入力規則」が設定されている為、出来ないのです。VBAでの方法があれば宜しくお願い致します。ありがとうございました。