Find duplicates in a column

Question

The code below counts the duplicates in a particular column and displays the number of duplicates, but I need it to state "Duplicate found" in a subsequent cell if there is/are any duplicates. For instance, if values are the same in cells F3, F4, and F15. Blank column (column "G" is already present because I am verifying column "F"), then it should be sorted, and "Duplicate discovered" should appear in cells G3, G4, and G15.

Dim helperCol As Range
Dim count As Long

With Worksheets("Sheet1")
    Set helperCol = .UsedRange.Resize(, 1).Offset(, .UsedRange.Columns.count)
    With .Range("F1", .Cells(.Rows.count, 6).End(xlUp))
        helperCol.Value = .Value
        helperCol.RemoveDuplicates Columns:=1, Header:=xlYes
        count = .SpecialCells(xlCellTypeConstants).count - helperCol.SpecialCells(xlCellTypeConstants).count
    End With
    helperCol.ClearContents
End With

If count >= 1 Then
    Range(count, "G") =   " Duplicate/s found"
End If

the output should look like this:- (Bold font is done by me only just for clear understanding its not required )

Answer 1

If any cells in column "F" contain duplicates, this code will display "Duplicate Found" in the cell 1 across to the right (i.e., column "G") of those cells.

Option Explicit

Sub Test()

    Dim CEL As Range, RANG As Range

    With Worksheets("Sheet1")

        ' Build a range (RANG) between cell F2 and the last cell in column F
        Set RANG = Range(.Cells(2, "F"), .Cells(.Rows.Count, "F").End(xlUp))

    End With

    ' For each cell (CEL) in this range (RANG)
    For Each CEL In RANG

        ' If the count of CEL in RANG is greater than 1, then set the value of the cell 1 across to the right of CEL (i.e. column G) as "Duplicate Found"
        If Application.WorksheetFunction.CountIf(RANG, CEL.Value) > 1 Then CEL.Offset(, 1).Value = "Duplicate Found"

    Next CEL

End Sub

Another choice is to utilise a dictionary, which keeps track of distinct values and their ranges (first add a reference to Microsoft Scripting Runtime). As you work your way down the range, you fill in the Dictionary. If a value is already there, you should note "Duplicate found" for the initial range and all subsequent occurrences.

Tools > References

Sub Test2()

    Dim CEL As Range, RANG As Range
    Dim dict As New Scripting.Dictionary

    With Worksheets("Sheet1")

        ' Build a range (RANG) between cell F2 and the last cell in column F
        Set RANG = Range(.Cells(2, "F"), .Cells(.Rows.Count, "F").End(xlUp))

    End With

    ' For each cell (CEL) in this range (RANG)
    For Each CEL In RANG

        If CEL.Value <> "" Then ' ignore blank cells

            If Not dict.Exists(CEL.Value) Then ' if the value hasn't been seen yet
                dict.Add CEL.Value, CEL ' add the value and first-occurrence-of-value-cell to the dictionary
            Else ' if the value has already been seen
                CEL.Offset(, 1).Value = "Duplicate Found" ' set the value of the cell 1 across to the right of CEL (i.e. column G) as "Duplicate Found"
                dict(CEL.Value).Offset(, 1).Value = "Duplicate Found" ' set the value of the cell 1 across to the right of first-occurrence-of-value-cell (i.e. column G) as "Duplicate Found"
            End If

        End If

    Next CEL

    Set dict = Nothing

End Sub

I hope this helps you.