表内で2つ以上内容が重複する行があったらその行に色を付けたい

Question

findを使った際のIfの条件付けで行き詰ってます。
お力を貸して頂ければ幸いです。

日本語の列（A列）と英語の列(B列)から成る表があります。
表の中で日本語と英語の両方が重複する行があった場合、その行を黄色くしたいと考えています。
下記のような感じです。

行番号	A列	B列	重複判定	処理
1	りんご	apple	行3と重複している	行1を黄色くする
2	りんご	orange	重複していない	何もしない
3	りんご	apple	行1と重複している	行3を黄色くする
4	オレンジ	apple	重複していない	何もしない
4	オレンジ	orange	重複していない	何もしない

findで検索の基準になるセル（行）を除き、基準から上、基準から下に分けて検索を掛けましたが、
表内の単語数が増えたり、行の順番が入れ替わると正しく重複を見つけることができません。
組んでみたコードは下記です。

1: Workbooks(From_Book).Sheets(From_Sheet).Activate
2: EndRow = Workbooks(From_Book).Sheets(From_Sheet).Cells(Rows.Count, 1).End(xlUp).Row '登録元日本語最終セル
3: FinalRow = Workbooks(From_Book).Sheets(From_Sheet).Cells(Rows.Count, 2).End(xlUp).Row '登録元英語最終セル

4: rr = 1
5: For i = 6 To EndRow Step 1 '登録元日本語最終セルの回数分処理をする

6: '登録元の日本語の重複チェック (全角と半角の区別なし)
'日本語の基準セルから下のセルを検索
7: Set myRange = Workbooks(From_Book).Sheets(From_Sheet).Range(Cells(i + 1, 1), Cells(EndRow + 1, 1))
8: keyword = Workbooks(From_Book).Sheets(From_Sheet).Cells(i, 1).Value
9: Set myObj = myRange.Find(keyword, LookAt:=xlWhole, MatchByte:=False)

'日本語の基準セルから上のセルを検索
10: Set myRange = Workbooks(From_Book).Sheets(From_Sheet).Range(Cells(i - rr, 1), Cells(i - 1, 1))
11: keyword = Workbooks(From_Book).Sheets(From_Sheet).Cells(i, 1).Value
12: Set myObj3 = myRange.Find(keyword, LookAt:=xlWhole, MatchByte:=False)

13: '登録元の英語の重複チェック (大文字と小文字の区別なし)
14: '英語の基準セルから下のセルを検索
15: Set myRange = Workbooks(From_Book).Sheets(From_Sheet).Range(Cells(i + 1, 2), Cells(EndRow + 1, 2))
16: keyword = Workbooks(From_Book).Sheets(From_Sheet).Cells(i, 2).Value
17: Set myObj2 = myRange.Find(keyword, LookAt:=xlWhole, MatchCase:=False, MatchByte:=False)

18: '英語の基準セルから上のセルを検索
19: Set myRange = Workbooks(From_Book).Sheets(From_Sheet).Range(Cells(i - rr, 2), Cells(i - 1, 2))
20: keyword = Workbooks(From_Book).Sheets(From_Sheet).Cells(i, 2).Value
21: Set myObj4 = myRange.Find(keyword, LookAt:=xlWhole, MatchCase:=False, MatchByte:=False)
22: rr = rr + 1

23: '日本語と英語の両方が重複していない行と判定された場合
24: If myObj Is Nothing And myObj3 Is Nothing And myObj2 Is Nothing And myObj4 Is Nothing Then
25: Workbooks(From_Book).Sheets(From_Sheet).Cells(6, 1).Select

26: '日本語と英語の両方が重複する行と判定された場合、その行を黄色くする
27: Workbooks(From_Book).Sheets(From_Sheet).Range(Cells(i, 1), Cells(i, 6)).Interior.Color = vbYellow
28: End If

29: Next i

～以下、黄色いセルを検索し、メッセージボックス表示させ、subを抜けるコードに続く～

Answer 1

こんな感じでどうでしょうか。

Sub sample()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    Dim EndRow
    EndRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    
    Dim rng As Range
    Set rng = ws.Cells.Resize(EndRow, 2)

    Dim i
    For i = 1 To EndRow
        If WorksheetFunction.CountIfs(rng.Columns(1), rng(i, 1), rng.Columns(2), rng(i, 2)) > 1 Then rng.Rows(i).Interior.ColorIndex = 3
    Next
End Sub

あるいは条件付き書式で。

=COUNTIFS($A:$A,$A1,$B:$B,$B1) > 1

Comments

[退会済みユーザー]

ご回答、ありがとうございます。
この処理の後に単語の登録等があるので、前者のコードになるかと思います。
今回は時間がないので、別の方法で解決となってしまいましたが、
Jinojiさんのコードの方が短くて、処理が速そうです。勉強させて頂きます。

Answer 2

複数列の重複データ抽出ですが、VBAを使わずにExcelで
作業列を作成して抽出してはどうでしょうか。

エクセル 重複データを抽出する

Comments

[退会済みユーザー]

ご回答、ありがとうございます。
ご教示頂いた作業をVBAに組み込むことで今回は解決ができました。

Answer 3

列を挿入し、そこにA列の値+B列の値を入れ、元から組んであるFindのコードを利用して解決できました。
teratailのように相談できる方が近くにいると良いのですが...。
一人で考えるとドツボにハマってしまいますね。

皆さん、迅速なご回答ありがとうございました。