Excel VBA- Find Unique Records

By Ajeet Kumar

EXCEL VBA TO RETRIEVE RECORDS FROM A DATA RANGE

To find out all unique records from a data range under following assumptions.

1. There is no blank row in the data range.
2. The combination of first two columns constitutes primary key.
3. There may be duplicity of the primary key.

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 more than 1.

 Code:

Sub pUniqueRecs()

    Dim lngFR As Long

    Dim lngLC As Long

    Dim rngData As Range

    Dim rngDelete As Range

    

    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"

    ''Add a value greater than 1 in column A to avoid run time error

    ShTarget.Range("A" & ShTarget.Rows.Count).End(xlUp).Offset(1) = 2

    ''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

End Sub