MOSTRAR CÉLULAS COM VALORES DUPLICADOS

 Evidenciar células com valores duplicados

Se pretendermos evidenciar as células que contêm valores duplicados (ver exemplo):

O Código:

Sub ColorDupRows()
    Dim rngSrc As Range
    Dim NumRows As Integer
    Dim ThisRow As Integer
    Dim ThatRow As Integer
    Dim ThisCol As Integer
    Dim RightCol As Integer
    Dim J As Integer, K As Integer

    Application.ScreenUpdating = False
    Set rngSrc = ActiveSheet.Range(ActiveWindow.Selection.Address)

    NumRows = rngSrc.Rows.Count
    ThisRow = rngSrc.Row
    ThatRow = ThisRow + NumRows - 1
    ThisCol = rngSrc.Column
    RightCol = ThisCol + rngSrc.Columns.Count - 1

    For J = ThisRow To (ThatRow - 1)
        If Cells(J, ThisCol) > "" Then
            For K = (J + 1) To ThatRow
                If Cells(J, ThisCol) = Cells(K, ThisCol) Then
                    With Cells(K, ThisCol).Interior
                        .ColorIndex = 20
                        .Pattern = xlSolid
                    End With

                End If
            Next K
        End If
    Next J

    Application.ScreenUpdating = True
End Sub