ExcelVBAを使って重複箇所のセルに色を付ける

Excelでデータを整理する際、重複箇所に色を付けたいケースがあります。
条件付き書式を設定することで簡単に色を付けることができますが、
今回はVBAを使って重複した2番目以降のデータについて色を付けるサンプルアプリをご紹介します。

サンプルアプリ実行動作

「重複箇所色付け」ボタンをクリックすると重複箇所に色が付きます。

サンプルコードの処理内容

処理の内容については以下の通りです。
今回はDictionary(連想配列)オブジェクトを使ってオブジェクト変数にデータをセットしていきます。
データをセットするにあたりすでにオブジェクト変数内に存在するデータであればデータをセットせずセルに色を付けます。
オブジェクト変数内に存在しないデータであれば追加していきます。
セルに色を付けるかどうかはオブジェクト変数内に該当のデータが存在するかで判断していきます。
メソッド、プロパティについては以下のリンク先をご覧ください。
Dictionary オブジェクト

また、セルを着色する際に、「Interior.ColorIndex = 40」としていますが、カラー番号の一覧は以下の通りです。サンプルアプリではカラー番号「40」を指定しています。


【処理内容】

各ワークシートオブジェクトの取得
     ↓
各種変数の定義
     ↓
Dictionary(連想配列)オブジェクトの宣言
     ↓
オブジェクト型変数にDictionary(連想配列)オブジェクトを格納
     ↓
データ部分の最終行の行番号を取得
     ↓
データ範囲をループ処理
     ↓
Dictionaryオブジェクト内に同じデータがあればセルを着色
同じデータがなければDictionaryオブジェクトにデータ追加
     ↓
データ範囲をループ処理
     ↓
Dictionaryオブジェクトリセット
     ↓
処理完了メッセージの表示

サンプルコード  アプリの作成手順はこちら

Option Explicit

Sub 重複データ色付け()
  'ワークシートを指定する
   Dim Sh1 As Worksheet
   Set Sh1 = ThisWorkbook.Worksheets("Sheet1")

  '変数を定義します。
   Dim Dic, i As Long, K As Long, buf As String
 
  'Dictionaryオブジェクトの宣言
   Set Dic = CreateObject("Scripting.Dictionary")

  'データの最終行を取得
   K = Sh1.Cells(Rows.Count, 2).End(xlUp).Row
   
  'データ範囲(5行目~データ最終行)を上から順番にループ処理でチェック
   For i = 5 To K
    buf = Sh1.Cells(i, 2).Value
       
   '同じデータがあれば
    If Dic.Exists(buf) Then
    
     'セルに色を着色
      Sh1.Cells(i, 2).Interior.ColorIndex = 40
      
    Else

     '同じデータがなければDictionaryオブジェクトにデータ追加
      Dic.Add buf, buf
      
    End If
    
   Next i
   
  'Dictionaryオブジェクトリセット
   Set Dic = Nothing

  '完了メッセージの表示
   MsgBox "処理が完了しました。"

End Sub