Excel VBA- Find all duplicate records

EXCEL VBA TO RETRIEVE ALL DUPLICATE RECORDS OF A DATA RANGE

Objective: To find out all duplicate records from a data range under the following assumptions.

1. There is no blank row in the data range.
2. The combination of first two columns constitutes primary key.
3. Duplicity of the primary key is treated as duplicate record.

Solution:

1. Paste the data range to a new sheet at cell C1.
2. Apply formula in column B to concatenate column C and D.
3. Find out the count of values of column B in column A.
4. Apply filter at column A.
5. Remove all records which count is 1.

Option Explicit

Sub pDuplicateRecs()

    Dim lngFR As Long

    Dim lngLC As Long

    Dim rngData As Range

    Dim rngDelete As Range

    

    Application.ScreenUpdating = False

    On Error GoTo lblErr

    

    ShTarget.Cells.Clear

    ShSource.Range("A1").CurrentRegion.Copy

    ShTarget.Range("C1").PasteSpecial xlPasteValues

    Application.CutCopyMode = False

    ''Assuming that there is no blank row

    ''Count Total Rows and Columns of data range

    lngFR = ShTarget.Range("C1").CurrentRegion.Rows.Count

    lngLC = ShTarget.Range("C1").CurrentRegion.Rows.Count

    ''Assuming that data range has column headers

    ''Assuming that first two column combination must be unique

    ShTarget.Range("B2:B" & lngFR).FormulaR1C1 = "=RC[1]&""|""&RC[2]"

    ShTarget.Range("B2:B" & lngFR).Value = ShTarget.Range("B2:B" & lngFR).Value

    ''Find the Count of Duplicates and Unique Data

    ShTarget.Range("A2:A" & lngFR).FormulaR1C1 = "=COUNTIF(R2C2:R" & lngFR & "C2,RC[1])"

    ShTarget.Range("A2:A" & lngFR).Value = ShTarget.Range("A2:A" & lngFR).Value

    ShTarget.Range("A1") = "Count"

    ShTarget.Range("B1") = "Data"

    ''Apply Filter

    ShTarget.Range("A1").AutoFilter

    Set rngData = ShTarget.Range("A1").Resize(lngFR, lngLC)

    ''Filter the Unique records

    rngData.AutoFilter Field:=1, Criteria1:="1"

    Set rngDelete = rngData.SpecialCells(xlCellTypeVisible)

    ''Remove Filter

    rngData.AutoFilter

    ''Delete Unique Records

    rngDelete.EntireRow.Delete

    ''Remove helping columns

    ShTarget.Range("A:B").Delete

    ShTarget.Range("A1").EntireRow.Insert

    ShSource.Range("A1").Resize(ColumnSize:=ShSource.Range("A1").CurrentRegion.Columns.Count).Copy ShTarget.Range("A1")

    ShTarget.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous

    

lblErr:

    If Err.Number <> 0 Then

    MsgBox "Error Number:" & Err.Number & vbCrLf & "Error Description: " & Err.Number

    End If

Application.ScreenUpdating = True

End Sub