EXCEL VBA 自由に選択範囲の重複データのハイライト表示・重複件数により色分け（テクニック）

2023年11月12日

EXCEL VBA 自由に選択範囲の重複データのハイライト表示・重複件数により色分け（テクニック）

●はじめに

今回説明するサンプルプログラムは、Excelのワークシートで選択された範囲内のセルについて、重複する値を持つセルを黄色でハイライトする機能を持っています。事務業務においては、顧客リストや商品リストなどのデータで重複を素早く識別する際に役立ちます。たとえば、顧客データベースで重複する顧客名を見つけ出し、データの整合性を保つためのクリーニング作業を効率化することができます。また、在庫管理においても同一商品の重複エントリーを発見するのに使用できます。このように、データの重複を視覚的に確認しやすくすることで、データの品質管理やエラーの検出を効率的に行うことが可能になります。

●【EXCEL VBA 選択セル・選択行・列　フォントカラーでハイライト表示（強調）、下記を参照して下さい】

EXCEL VBA 選択セル・選択行・列　フォントカラーでハイライト表示・選択列・選択行を目立たせる・強調）テクニック

●【EXCEL VBA　選択セル・選択行・列　ハイライト表示、下記を参照して下さい】

EXCEL VBA 選択セル・選択行・列　ハイライト表示・目立たせる・見やすく・強調）テクニック

●【Worksheet.SelectionChange イベント (Excel)、下記を参照して下さい】（Microsoft社　様）】
https://learn.microsoft.com/ja-jp/office/vba/api/excel.worksheet.selectionchange

Excel VBAで重複データを簡単に見つける方法：VBAマクロを使ったセルの自動ハイライト機能の紹介

●プログラム説明　(サンプル①)

今回説明するサンプルプログラムExcel内で選択された範囲内のセルを走査し、重複する値を持つセルを黄色でハイライトするプログラムです。具体的には、選択範囲内の各セルの値をチェックし、それぞれの値が何回出現するかをカウントします。その後、出現回数が1より大きい（つまり重複している）セルの背景色を黄色に変更します。
※マウスでEXCELのセル範囲を指定して、指定した範囲内で自動的に重複セルを検索して該当セルの背景色を黄色に塗りつぶします。

【プログラムの流れ】

ユーザーがセル範囲を選択すると、Worksheet_SelectionChangeイベントがトリガーされます。
スクリプト辞書オブジェクトが作成されます。
選択された範囲が変数rngに設定されます。
選択範囲内の各セルに対してループを行い、空でないセルの値を辞書に記録し、出現回数をカウントします。
再度、選択範囲内の各セルに対してループを行い、出現回数が1より大きいセルを黄色でハイライトします。
辞書オブジェクトが解放されます。

【プログラム実行条件・注意事項】

このマクロはセル範囲が変更されるたびに自動的に実行されるため、大きな範囲を選択すると処理が遅くなる可能性があります。
このマクロは選択されたセル範囲内のみで動作し、ワークシート全体の重複をチェックするわけではありません。
マクロを実行すると、以前に設定されたセルの色がクリアされます。そのため、色情報は失われます。★注意：下記のプログラムを実行するには、ワークシートプロシージャの「Worksheet」・「SelectionChange」に登録する。

★【サンプルプログラム】
下記のリンク先よりサンプルプログラムをダウンロードする事ができます。
●　duplicatecolorcoding01（サンプルプログラム）

’
’
Option Explicit


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim rng As Range
    Dim cell As Range
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary") ' 辞書オブジェクトの作成
    
    ' 選択範囲を変数rngに設定
    Set rng = Selection
    
    ' 選択範囲が1つのセルのみの場合は何もしない
    If Target.Cells.CountLarge = 1 Then Exit Sub
    
    ' 以前にハイライトされたセルの色をクリア
    Cells.Interior.ColorIndex = xlNone
    
    ' 選択範囲内のセルの値を辞書に記録し、出現回数をカウント
    For Each cell In rng
        If Not cell.Value = "" Then ' 空のセルは無視
            If dict.Exists(cell.Value) Then
                dict(cell.Value) = dict(cell.Value) + 1 ' 既にキーが存在する場合はカウントアップ
            Else
                dict(cell.Value) = 1 ' 新しいキーを辞書に追加
            End If
        End If
    Next cell
    
    ' 重複があるセルをハイライト
    For Each cell In rng
        If Not cell.Value = "" Then
            If dict(cell.Value) > 1 Then
                cell.Interior.Color = RGB(255, 255, 0) ' 出現回数が1より大きいセルを黄色でハイライト
            End If
        End If
    Next cell
    
    ' 辞書オブジェクトの解放
    Set dict = Nothing
End Sub
’

’

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim rng As Range

Dim cell As Range

Dim dict As Object

Set dict = CreateObject("Scripting.Dictionary") ' 辞書オブジェクトの作成

' 選択範囲を変数rngに設定

Set rng = Selection

' 選択範囲が1つのセルのみの場合は何もしない

If Target.Cells.CountLarge = 1 Then Exit Sub

' 以前にハイライトされたセルの色をクリア

Cells.Interior.ColorIndex = xlNone

' 選択範囲内のセルの値を辞書に記録し、出現回数をカウント

For Each cell In rng

If Not cell.Value = "" Then ' 空のセルは無視

If dict.Exists(cell.Value) Then

dict(cell.Value) = dict(cell.Value) + 1 ' 既にキーが存在する場合はカウントアップ

Else

dict(cell.Value) = 1 ' 新しいキーを辞書に追加

End If

Next cell

' 重複があるセルをハイライト

For Each cell In rng

If Not cell.Value = "" Then

If dict(cell.Value) > 1 Then

cell.Interior.Color = RGB(255, 255, 0) ' 出現回数が1より大きいセルを黄色でハイライト

End If

Next cell

' 辞書オブジェクトの解放

Set dict = Nothing

End Sub

’

●実行前～実行後　※このコードが含まれるワークシートでセル範囲が変更されると、選択された範囲内で重複する値を持つセルが自動的に黄色でハイライトされます。ただし、1つのセルのみが選択されている場合は何も起こりません。また、新しいセル範囲が選択されるたびに、以前にハイライトされたセルの色はクリアされます。
（画面クリックして拡大）

Excel VBAでデータ重複を即座に視覚化！選択範囲に応じた色の変更で重複をハイライトするVBAマクロの作成方法

●プログラム説明　(サンプル②)

下記のサンプルプログラムは、Excelのワークシートにおいて、ユーザーが新しいセル範囲を選択するたびに実行されるイベントベースのマクロです。具体的には、ユーザーがA1からG1000までの範囲内でセルを選択した際に、その選択範囲内のセルの値をチェックし、重複している値を持つセルを異なる色でハイライトします。重複の度合いに応じて色が変わり、2回の重複は青色、3回から5回の重複は黄色、6回以上の重複は赤色でハイライトされます。

【プログラムの流れ】

ユーザーがセルを選択すると、Worksheet_SelectionChange イベントがトリガーされます。
A1からG1000までの範囲を CheckRange として設定します。
ユーザーが選択した範囲が CheckRange と交差しない場合、処理は終了します。
CheckRange 内のセルのハイライトをクリアします。
選択された範囲内の各セルについて、そのセルの値が空でない場合、その値の出現回数をカウントします。
カウントした結果を基に、重複している値を持つセルを色付けします。重複の回数に応じて色が決定されます。
辞書オブジェクトをクリアして処理を終了します。

【プログラム実行条件・注意事項】

このマクロはワークシート上でセル範囲が変更されるたびに実行されるため、大きな範囲を選択したり、頻繁にセルを選択するとパフォーマンスに影響を与える可能性があります。
Worksheet_SelectionChange イベントはセル選択の変更時にのみ発生するため、セルの内容が変更されても自動的には更新されません。
辞書オブジェクトを使用しているため、このコードはExcelのバージョンが辞書オブジェクトに対応している必要があります。
ColorIndex を使用している箇所は xlNone に設定されていますが、他の色を使用する場合は ColorIndex の値を適切に設定する必要があります。★注意：下記のプログラムを実行するには、ワークシートプロシージャの「Worksheet」・「SelectionChange」に登録する。

★【サンプルプログラム】
下記のリンク先よりサンプルプログラムをダウンロードする事ができます。
●　duplicatecolorcoding02　（サンプルプログラム）

’
’
Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ' A1からG1000の範囲をチェック範囲として設定
    Dim CheckRange As Range
    Set CheckRange = Me.Range("A1:G1000")
    
    ' 選択された範囲がチェック範囲外ならば処理を終了
    If Intersect(Target, CheckRange) Is Nothing Then Exit Sub
    
    ' チェック範囲内のセルのハイライトをクリア
    CheckRange.Interior.ColorIndex = xlNone
    
    Dim cell As Range
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 選択された範囲内のセルの値を辞書に記録し、出現回数をカウント
    For Each cell In Intersect(Target, CheckRange)
        If Not cell.Value = "" Then ' 空のセルは無視
            If dict.Exists(cell.Value) Then
                dict(cell.Value) = dict(cell.Value) + 1
            Else
                dict(cell.Value) = 1
            End If
        End If
    Next cell
    
    ' 重複値を持つセルに色を付ける。色は重複の回数によって決定される。
    For Each cell In Intersect(Target, CheckRange)
        If Not cell.Value = "" And dict.Exists(cell.Value) Then
            Select Case dict(cell.Value)
                Case 2
                    cell.Interior.Color = RGB(0, 0, 255) ' 重複が2回の場合は青色でハイライト
                Case 3 To 5
                    cell.Interior.Color = RGB(255, 255, 0) ' 重複が3回から5回の場合は黄色でハイライト
                Case Is >= 6
                    cell.Interior.Color = RGB(255, 0, 0) ' 重複が6回以上の場合は赤色でハイライト
            End Select
        End If
    Next cell
    
    ' 辞書オブジェクトの参照を解放
    Set dict = Nothing
End Sub
’
’

’

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

' A1からG1000の範囲をチェック範囲として設定

Dim CheckRange As Range

Set CheckRange = Me.Range("A1:G1000")

' 選択された範囲がチェック範囲外ならば処理を終了

If Intersect(Target, CheckRange) Is Nothing Then Exit Sub

' チェック範囲内のセルのハイライトをクリア

CheckRange.Interior.ColorIndex = xlNone

Dim cell As Range

Dim dict As Object

Set dict = CreateObject("Scripting.Dictionary")

' 選択された範囲内のセルの値を辞書に記録し、出現回数をカウント

For Each cell In Intersect(Target, CheckRange)

If Not cell.Value = "" Then ' 空のセルは無視

If dict.Exists(cell.Value) Then

dict(cell.Value) = dict(cell.Value) + 1

Else

dict(cell.Value) = 1

End If

Next cell

' 重複値を持つセルに色を付ける。色は重複の回数によって決定される。

For Each cell In Intersect(Target, CheckRange)

If Not cell.Value = "" And dict.Exists(cell.Value) Then

Select Case dict(cell.Value)

Case 2

cell.Interior.Color = RGB(0, 0, 255) ' 重複が2回の場合は青色でハイライト

Case 3 To 5

cell.Interior.Color = RGB(255, 255, 0) ' 重複が3回から5回の場合は黄色でハイライト

Case Is >= 6

cell.Interior.Color = RGB(255, 0, 0) ' 重複が6回以上の場合は赤色でハイライト

End Select

End If

Next cell

' 辞書オブジェクトの参照を解放

Set dict = Nothing

End Sub

’

●実行前～実行後　※このコードを実行すると、ユーザーがワークシート上でA1からG1000の範囲内のセルを選択した際に、選択された範囲内で重複している値を持つセルが色付けされます。具体的には、値が2回重複しているセルは青色、3回から5回重複しているセルは黄色、6回以上重複しているセルは赤色でハイライトされます。これにより、ユーザーは重複しているデータを容易に視覚的に識別することができます。
（画面クリックして拡大）

最後まで、ご覧いただきまして誠に有難うございました。
また、VBAに関するテクニックや便利な手法などをこのサイトに掲載していきますので、定期的に参照していただけると幸いです。

VBAプログラム（テクニック）EXCEL, VBA