VBA 矩形選択範囲で重複データの入ったセルを塗りつぶす方法

重複データを探すというのは比較的よくやる処理だけれど、データが矩形に配置されていてその姿のまま処理したい場合は関数では少々面倒くさい。

今回は選択した矩形範囲のデータから内容の重複するセルを塗りつぶして可視化するマクロを作った。
ちなみに定数でどれを何色で塗るか、塗らないかを選択できるようにした。

Sub 重複orユニークを塗る()
    Const 重複を塗る = True
    Const 重複セル色 = vbYellow
    Const ユニークを塗る = False
    Const ユニークセル色 = vbRed
    
    Dim arr: arr = Selection.Value
    Dim arr2: ReDim arr2(LBound(arr, 1) To UBound(arr, 1), LBound(arr, 2) To UBound(arr, 2))
    Dim i, j, k, l
    For i = LBound(arr, 1) To UBound(arr, 1)
        For j = LBound(arr, 2) To UBound(arr, 2)
            For k = LBound(arr, 1) To UBound(arr, 1)
                For l = LBound(arr, 2) To UBound(arr, 2)
                    If Not (i = k And j = l) Then
                        arr2(i, j) = arr2(i, j) Or arr(i, j) = arr(k, l)
                    End If
    Next l, k, j, i
    
    Dim m, n
    For m = LBound(arr2, 1) To UBound(arr2, 1)
        For n = LBound(arr2, 2) To UBound(arr2, 2)
            If arr2(m, n) And 重複を塗る Then
                Selection(m, n).Interior.Color = 重複セル色
            ElseIf (Not arr2(m, n)) And ユニークを塗る Then
                Selection(m, n).Interior.Color = ユニークセル色
            End If
    Next n, m
End Sub

この手の処理はセル数の二乗の比較が必要になるので、いきなりセル上でやると効率が悪い。
そのため、まずセル範囲を配列arrに転記して配列内で比較を行い、別の配列arr2にその結果をBoolean型で格納している。

次のこの配列arr2を元に選択範囲を塗りつぶしている。

そして以下はテスト用に適当に選択範囲にアルファベットを埋めるコード。

Sub hoge()
    Dim r As Range
    For Each r In Selection
        r.Value = Chr(WorksheetFunction.RandBetween(Asc("a"), Asc("z")))
    Next
End Sub

適当に埋めたアルファベットのうち、前述のマクロで重複を塗りつぶしたのがこちら。

着想からコーディング、記事公開まで約50分。うむ。上出来。
やっぱ朝イチの集中力は素晴らしい。