VBAで行or列で重複している値のセルを色塗りしてみた

VBA VBA
この記事は約4分で読めます。

エクセルのマクロを利用して、行もしくは列で重複している値のセルを色塗りしてみました。

広告

1.行で重複している値のセルを色塗りする

やりたいことは以下の画像のように、行で重複している値がある場合に、重複している値のセルを色塗りする、というものです。
画像では重複している [a] と [f] という値について色塗りをしています。

特定の行で重複している値のセルを色塗りした状態

以下のvbaで色塗り可能です。

Sub HighlightDuplicates()
    Dim ws As Worksheet
    Dim lastCol As Long
    Dim i As Long, j As Long
    Dim cell As Range
    
    ' 対象となるシートを指定
    Set ws = ThisWorkbook.Sheets("Sheet1") ' シート名を適切なものに変更
    
    ' 最終列の取得
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    ' 各列をループして重複を探す
    For i = 1 To lastCol
        For j = 1 To lastCol
            ' 同じ列は比較しない
            If i <> j Then
                ' セルの値が重複している場合は色を塗る
                For Each cell In ws.Range(ws.Cells(1, i), ws.Cells(ws.Rows.Count, i).End(xlUp))
                    If cell.value = ws.Cells(cell.Row, j).value Then
                        cell.Interior.Color = RGB(255, 255, 0) ' 黄色に塗りつぶす
                    End If
                Next cell
            End If
        Next j
    Next i
End Sub

複数行でも実行可能

以下のように複数行でも実行可能です。
この場合、それぞれの行で重複している個所を色塗りします。

複数行で重複している値のセルを色塗りした状態

[注意点] 空行があると実行できない

1行目などが空行だと正常に動作しないので注意が必要です。

1行目などが空行だとマクロが正常に動作しない

2.列で重複している値のセルを色塗りする

やりたいことは以下の画像のように、列で重複している値がある場合に、重複している値のセルを色塗りする、というものです。
画像では [a] という値が1行目、7行目、14行目にありますが、7行目、14行目の重複している値にだけ色塗りをしています。

特定の列で重複している値のセルを色塗りした状態

以下のvbaで色塗り可能です。

Sub HighlightDuplicates()
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim dict As Object
    Dim lastRow As Long
    
    ' 対象のシートと列を設定
    Set ws = ThisWorkbook.ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Set rng = ws.Range("A1:A" & lastRow)
    
    ' 重複を見つけて色を付けるための辞書を作成
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 重複するセルを色付け
    For Each cell In rng
        If cell.Value <> "" Then
            If dict.exists(cell.Value) Then
                cell.Interior.Color = RGB(255, 255, 0) ' 黄色で塗りつぶし
            Else
                dict.Add cell.Value, 1
            End If
        End If
    Next cell
End Sub
タイトルとURLをコピーしました