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

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

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

’
’
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
’

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

’
’
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
’
’