Excel Forum

Code: Select all

Sub ListDup()
    Dim rAll As Range
    Dim r As Range
    Dim rTarget As Range
    With Sheets("Sheet1")
        .Range("H2", .Range("H2").End(xlDown)).ClearContents
        Set rAll = .Range("G2", .Range("G" & Rows.Count).End(xlUp))
        Set rTarget = .Range("H2", .Range("H" & Rows.Count).End(xlUp))
        For Each r In rAll
            If Application.CountIf(rAll, r) > 1 And Application.CountIf(rTarget, r) = 0 Then
                .Range("H" & Rows.Count).End(xlUp).Offset(1, 0) = r
                Set rTarget = .Range("H2", .Range("H" & Rows.Count).End(xlUp))
            End If
        Next r
    End With
End Sub