エクセルで表を比較して重複セルの項目ごとに色を変えるマクロボタンを作る方法

エクセル

2024.05.28

あなたはエクセルの表で重複チェックするのが面倒だと思ったことはありませんか？

重複がわかっても、どれとどれが重複なのか、それをマーキングするのが大変ですよね。

エクセルのマクロを使えば、重複チェックして、重複項目ごとに色を変えられるので、チェックが簡単にできます。

今回は「エクセルで表を比較して重複セルの項目ごとに色を変えるマクロボタンを作る方法」を紹介します。

エクセルで表を比較して重複セルの項目ごとに色を変えるマクロボタンを作る方法
重複する項目の色を100種類に変える
まとめ

エクセルで表を比較して重複セルの項目ごとに色を変えるマクロボタンを作る方法

エクセルで表を比較して重複セルの項目ごとに色を変えるマクロボタンを作る方法です。

今回は、下のような３つの表で重複チェックする例を紹介します。

マクロを作るときは、「開発」タブを使います。
開発タブが出ていない方は、下のリンクで出し方を紹介していますので、まずは準備をお願いします。
→エクセルで開発タブを表示する方法

１．「開発」タブをクリック　→「挿入」をクリック　→「ボタン」をクリック

２．「新規作成」をクリック

３．コード入力画面が開く

４．コードを入力

コードを入力します。

３つの表の選んで、重複を確認して、重複箇所の色を変える、という意味です。

赤枠部のコードです。

    Dim rng1 As Range
    Dim rng2 As Range
    Dim rng3 As Range
    Dim cell1 As Range
    Dim cell2 As Range
    Dim cell3 As Range
    Dim duplicateCount As Integer
    Dim foundDuplicate As Boolean
    Dim colorIndex As Integer
    Dim colorArray As Variant
    
    ' 色の配列を定義
    colorArray = Array(RGB(255, 255, 0), RGB(255, 0, 0), RGB(0, 255, 0), RGB(0, 0, 255), RGB(255, 0, 255), RGB(0, 255, 255))
    
    ' ユーザーに最初の範囲を選択させる
    On Error Resume Next
    Set rng1 = Application.InputBox("比較する最初の表を選択してください:", "表1の選択", Type:=8)
    On Error GoTo 0
    
    If rng1 Is Nothing Then
        MsgBox "表1が選択されていません。マクロを終了します。", vbExclamation
        Exit Sub
    End If
    
    ' ユーザーに2番目の範囲を選択させる
    On Error Resume Next
    Set rng2 = Application.InputBox("比較する2番目の表を選択してください:", "表2の選択", Type:=8)
    On Error GoTo 0
    
    If rng2 Is Nothing Then
        MsgBox "表2が選択されていません。マクロを終了します。", vbExclamation
        Exit Sub
    End If
    
    ' ユーザーに3番目の範囲を選択させる
    On Error Resume Next
    Set rng3 = Application.InputBox("比較する3番目の表を選択してください:", "表3の選択", Type:=8)
    On Error GoTo 0
    
    If rng3 Is Nothing Then
        MsgBox "表3が選択されていません。マクロを終了します。", vbExclamation
        Exit Sub
    End If
    
    ' 重複のカウントをリセット
    duplicateCount = 0
    colorIndex = 0
    
    ' 最初の範囲内の各セルをループ
    For Each cell1 In rng1
        ' 2番目の範囲内の各セルと比較
        For Each cell2 In rng2
            If cell1.Value = cell2.Value And cell1.Value <> "" Then
                ' 3番目の範囲内の各セルと比較
                foundDuplicate = False
                For Each cell3 In rng3
                    If cell1.Value = cell3.Value Then
                        ' 重複している場合、セルを現在の色で塗る
                        cell1.Interior.Color = colorArray(colorIndex Mod UBound(colorArray) + 1)
                        cell2.Interior.Color = colorArray(colorIndex Mod UBound(colorArray) + 1)
                        cell3.Interior.Color = colorArray(colorIndex Mod UBound(colorArray) + 1)
                        duplicateCount = duplicateCount + 1
                        foundDuplicate = True
                        colorIndex = colorIndex + 1 ' 次の色に変更
                        Exit For
                    End If
                Next cell3
                If foundDuplicate Then Exit For
            End If
        Next cell2
    Next cell1
    
    ' 重複の数をメッセージボックスで表示
    MsgBox "重複したセルは " & duplicateCount & " 件ありました。", vbInformation

コードを入力したら、コードの入力画面を閉じて下さい。

５．ボタンができた　→ボタンをクリック

ボタンができたら、ボタンをクリックします。