第10回直感！スグに使える業務向けVBA汎用プロシージャ(重複抽出応用)

Last updated at 2025-04-29Posted at 2025-04-29

第0回で配布しました汎用プロシージャのコードの紹介と簡単な解説をやっていきたいと思います！
以下のリンクから .bas ファイルをダウンロードできます（zipファイル）

今回ご紹介するプロシージャは

プロシージャ名	概要
HighlightDuplicates	セル範囲内の重複値をランダム色で強調表示

恐らく皆さまお仕事の中でExcel上の大量のデータの中から重複した値が入っているセルの塗りつぶしを手作業で行った経験あるかと思います...大変ですよね、情報量が膨大だと目が痛くなりますよね(泣)

と、いうことで第9回にてご紹介したGetDuplicateValuesを応用して、指定したセルの範囲の中から重複した値のセルをその値ごとにランダムな色を割り当てその色で塗りつぶしてしまうという目に優しい(？)プロシージャとなっております。

重複セルに対して色を塗りつぶすというプロシージャは「VBA 重複セル塗りつぶし」などで検索していただくと様々な方が作られたプロシージャが出てきます。その中でも私が作った本プロシージャの差別化・工夫点としましては、

・多数の重複値に対応(一度に100個まで、それ以上の重複値が見つかった場合はエラー出力)
・RGB値を乱数にて生成、ユーザーによる設定等が不要
・グレースケールや色味の近い色の生成を避けるよう制御(重複が多いと近めの色が生成される場合もあります)

となります。なかなかツール開発で乱数を使うってことはないかと思われますが、過去に科学技術系課題の解析のために乱数を活用した簡単な物理演算シミュレータの開発をやっておりました。そういった経験から乱数には慣れ親しんでいたため、今回の発想に行きつきました。(いつかデータ分析の記事も書いてみたいななんて考えております...)

話を戻しまして、コードの紹介に移りたいと思います。

HighlightDuplicates

Sub HighlightDuplicates(startRow As Long, startCol As Long, endRow As Long, endCol As Long, Optional targetSheet As Worksheet)
'------------------------------------------------------------------------------------------------------------------------------
'　概要　　｜セル範囲の内容で重複した内容があれば自動でセルが塗りつぶされる
'------------------------------------------------------------------------------------------------------------------------------
'　引数１　｜startRow - 開始行番号(Long型)
'　引数２　｜startCol - 開始列番号(Long型)
'　引数３　｜endRow - 終了行番号(Long型)
'　引数４　｜endCol - 終了列番号(Long型)
'　引数５　｜targetSheet - 対象のワークシートオブジェクト(規定値:ActiveSheet)(Worksheet型)
'------------------------------------------------------------------------------------------------------------------------------
'　実装　　｜Ver.1.0.0(2025/04/20:新規)
'------------------------------------------------------------------------------------------------------------------------------
    
    Dim arrSize         As Long 'インデックス番号
    Dim dupCount        As Long '重複個数
    Dim vLoop           As Long '行ループカウンタ
    Dim hLoop           As Long '列ループカウンタ
    Dim checkIndex1     As Long 'インデックスループカウンタ
    Dim checkIndex2     As Long 'インデックスループカウンタ
    Dim checkIndex3     As Long 'インデックスループカウンタ
    Dim valueList()     As Variant '格納用配列
    Dim dupList         As Variant '重複値とその色コード格納用配列
    Dim surveyCell      As Range '指定セル範囲
    
    If targetSheet Is Nothing Then Set targetSheet = ActiveSheet
    
    'ユーザー定義エラー
    If startRow < 1 Or endRow < 1 Or startCol < 1 Or endCol < 1 Then
        Err.Raise vbObjectError + 1001, "HighlightDuplicates", "引数は1以上の整数にしてください"
    End If
    If startRow > endRow Or startCol > endCol Then
        Err.Raise vbObjectError + 1002, "HighlightDuplicates", "開始の数値は終了よりも小さいものにしてください"
    End If
    
    arrSize = 1
    
    'セル内容の抽出
    For vLoop = 1 To endRow - startRow + 1
        For hLoop = 1 To endCol - startCol + 1
            Set surveyCell = targetSheet.Cells(vLoop + startRow - 1, hLoop + startCol - 1)
            If surveyCell.Value <> "" Then
                ReDim Preserve valueList(arrSize)
                valueList(arrSize) = surveyCell.Value
                arrSize = arrSize + 1
            End If
        Next hLoop
    Next vLoop
    
    '重複内容をdupListに移し替え
    dupCount = 1
    arrSize = arrSize - 1
    ReDim dupList(arrSize, 4)
    
    For checkIndex1 = 2 To arrSize
        For checkIndex2 = checkIndex1 - 1 To 1 Step -1
            '重複を確認した場合
            If valueList(checkIndex2) = valueList(checkIndex1) Then
                For checkIndex3 = 1 To dupCount
                    If dupList(checkIndex3, 1) = valueList(checkIndex1) Then GoTo Skip1
                Next checkIndex3
                dupList(dupCount, 1) = valueList(checkIndex1) '重複しつつ、dupList内に存在しなければ追加
                dupCount = dupCount + 1
                Exit For
Skip1:
            End If
        Next checkIndex2
    Next checkIndex1
    
    '処理継続の判定
    dupCount = dupCount - 1
    If dupCount = 0 Then Exit Sub
    If dupCount > 100 Then
        MsgBox "重複が多すぎるためセルの範囲を調整してください"
        Exit Sub
    End If
    
    '重複に対して塗りつぶす色を生成
    Dim rNum    As Long 'R値
    Dim gNum    As Long 'G値
    Dim bNum    As Long 'B値
    
    For checkIndex1 = 1 To dupCount
Return1:
        'RGB値の乱数を生成
        rNum = WorksheetFunction.RandBetween(3, 12) * 17
        gNum = WorksheetFunction.RandBetween(3, 12) * 17
        bNum = WorksheetFunction.RandBetween(3, 12) * 17
        If rNum = gNum And rNum = bNum And gNum = bNum Then GoTo Return1 'グレースケールを回避
        If Abs(rNum - gNum) < 20 And Abs(rNum - bNum) < 20 And Abs(gNum - bNum) < 20 Then GoTo Return1 '近い色が生成されないよう調整
        dupList(checkIndex1, 2) = rNum
        dupList(checkIndex1, 3) = gNum
        dupList(checkIndex1, 4) = bNum
    Next checkIndex1
    
    '重複しているセルに対して確定した色で塗りつぶす
    For vLoop = 1 To endRow - startRow + 1
        For hLoop = 1 To endCol - startCol + 1
            Set surveyCell = targetSheet.Cells(vLoop + startRow - 1, hLoop + startCol - 1)
            If surveyCell.Value <> "" Then
                For checkIndex1 = 1 To dupCount
                    If surveyCell.Value = dupList(checkIndex1, 1) Then
                        surveyCell.Interior.Color = RGB(dupList(checkIndex1, 2), dupList(checkIndex1, 3), dupList(checkIndex1, 4))
                        Exit For
                    End If
                Next checkIndex1
            End If
        Next hLoop
    Next vLoop
    
End Sub

先ほど乱数を使って色を生成していると書きましたが、こんな感じに生成しております。

'RGB値の乱数を生成
rNum = WorksheetFunction.RandBetween(3, 12) * 17 'R値
gNum = WorksheetFunction.RandBetween(3, 12) * 17 'G値
bNum = WorksheetFunction.RandBetween(3, 12) * 17 'B値

RGB値は各0~255までの256段階の値を3つ組み合わせて約1600万色を表現しています。その各値について0を除いた255段階を17で割り15段階としました。さらに小さい値では暗く、大きい値では明るくなりすぎるので、その中間の3~12の10段階とし、最終的な色数を1000としました。また、あまり多すぎると結局見分けが大変になるので一度に扱える重複を100としたり、グレースケール(R値=G値=B値)や連続して近い色が生成されないようにするなどユーザーフレンドリーとなるよう制御をしております。

私の個人的なこだわりを語らせていただいたところで、第9回でも出した表のA1セルからG7セルの重複した値のセルに対して色を付けてみましょう！