ExcelVBAの複数列を対象とした重複チェック・カウントについてご教授お願いいたします。

初めて利用をさせていただきます。ExcelVBAについて詳しい方ご教授お願い致します。

Excelにて以下のような表でA列、B列の組み合わせで同一のレコードが3件あればMsgBoxで
その旨を表示させるようにしたいと考えております

A列(No)　　　B列(会社)　　　C列(品目)

1 　　　　　　　a社　　　　　ﾘﾝｺﾞ
2 　　　　　　　a社　　　　　ﾐｶﾝ
3 　　　　　　　b社　　　　　ﾊﾞﾅﾅ
4 　　　　　　　a社　　　　　ﾘﾝｺﾞ
5 　　　　　　　a社　　　　　ﾐｶﾝ
6 　　　　　　　a社　　　　　ﾘﾝｺﾞ

上記の表ですとa社りんごの組み合わせが3件になるのでメッセージ表示させたいです。

調べてみたところこのような場合の重複確認にdictionaryという関数？が使えそうと思いましたので以下のように作ってみました。

【試したこと】
繰り返し処理で1行ずつ値を確認
A列とB列の値を組み合わせ変数Keyに代入し
1行ごとに変数Keyの値が配列に登録されているかチェック
登録されていればcntxを+1、未登録の場合はカウントアップさせずに配列へ登録させる。
繰り返し処理が終了後、cntxの値を確認し10以上の場合はメッセージを出す

Dim Key As String
Dim checkDic As Dictionary
Set checkDic = New Dictionary

’重複カウント変数　重複値の2つ目からカウントするため初期値に1を代入
Dim cntx As Long: cntx = 1

Do
(繰り返し条件)
Key = .Cells(cntDate + 4,2).Text & .Cells(cntDate + 4,3).Text
If checkDic .Exists(Key) Then
cntx = cntx +1
Else
checkDic .Add Key 0
End If
cntDate +1
Loop

If cntx >= 10 Then
MsgBox"同一社名・品目は3件以上登録できません"
End If

上記のように記載し動かしてみたところ重複値があればctnxのカウントが増えはするのですが
Ｂ列Ｃ列の組み合わせごとにカウントするようになりません。(当たり前ではありますが...)
Ｂ列Ｃ列の組み合わせごとに重複する値を数える方法はありますでしょうか？

A列(No)　　　B列(会社)　　　C列(品目)

1 　　　　　　　a社　　　　　ﾘﾝｺﾞ　　　　　　　
2 　　　　　　　a社　　　　　ﾐｶﾝ
3 　　　　　　　b社　　　　　ﾊﾞﾅﾅ
4 　　　　　　　a社　　　　　ﾘﾝｺﾞ cntx+1(2)
5 　　　　　　　a社　　　　　ﾐｶﾝcntx+1(3)←別でカウントアップさせたい
6 　　　　　　　a社　　　　　ﾘﾝｺﾞ

拙い書き方で恐れ入りますがご存じの方いらっしゃいましたら教えてください。

行動規範の内容に同意します

回答2件

カウンターはcheckDicの値としてもちます。
ループ中に３件以上のケースが発生したときに表示するなら、

VBA
1            If checkDic(Key) >= 3 Then
2                MsgBox "同一社名・品目は3件以上登録できません"
3            End If

箇所を生かします。
最後にまとめて、表示するなら

VBA
1    For Each Key In checkDic.keys
2        If checkDic(Key) >= 3 Then
3            MsgBox ("3件以上の社名・品目=" & Key)
4        End If
5    Next

の箇所を生かします。
KeyはFor each文で使用するためVariant型にしています。
cntDateは適当に扱ってます。
with Activesheetも便宜的につけています。

VBA
1Public Sub 重複チェック()
2    Dim Key As Variant
3    Dim checkDic As Dictionary
4    Set checkDic = New Dictionary
5    Dim cntDate
6    '重複カウント変数　重複値の2つ目からカウントするため初期値に1を代入
7    cntDate = 1
8    With ActiveSheet
9        Do
10            If cntDate > 10 Then Exit Do
11            Key = .Cells(cntDate + 4, 2).Text & .Cells(cntDate + 4, 3).Text
12            If checkDic.Exists(Key) = False Then
13                checkDic.Add Key, 0
14            End If
15            checkDic(Key) = checkDic(Key) + 1
16            If checkDic(Key) >= 3 Then
17                MsgBox "同一社名・品目は3件以上登録できません"
18            End If
19            cntDate = cntDate + 1
20        Loop
21    End With
22    For Each Key In checkDic.keys
23        If checkDic(Key) >= 3 Then
24            MsgBox ("3件以上の社名・品目=" & Key)
25        End If
26    Next
27    MsgBox ("完了")
28End Sub
29

投稿2022/02/15 06:10

tatsu99

総合スコア5540

Yasu0202

2022/02/15 10:46

ご回答いただきありがとうございます。やりたいことを調べてても中々ピンとくるものが無かったので丁寧に解説していただき理解できました。大変感謝しております。回答いただきありがとうございました!!

行動規範の内容に同意します

ベストアンサー

提示のコードはそもそもコンパイルエラーで動きません。

Dictionary を使うなら、Key をB列 & C列にするのはいいのですが、その件数は、Itemに格納するようにしましょう。
提示のコードをなるべく尊重するなら下記のようなコードになります。

vba
1    Dim Key As String
2    Dim checkDic As Dictionary
3    Set checkDic = New Dictionary
4    
5    With Worksheets("Sheet1")
6        Dim RowNum As Long: RowNum = 4
7        Do Until .Cells(RowNum, 2).Text = ""
8            Key = .Cells(RowNum, 2).Text & " " & .Cells(RowNum, 3).Text
9            If checkDic.Exists(Key) Then
10                checkDic(Key) = checkDic(Key) + 1
11                If checkDic(Key) >= 3 Then
12                    MsgBox Key & "が3件以上あります。" & vbCrLf & "同一社名・品目は3件以上登録できません"
13                    Exit Do
14                End If
15            Else
16                checkDic.Add Key, 1
17            End If
18            RowNum = RowNum + 1
19        Loop
20    End With