CODEWITHSUNDEEP
excelvba
Synectouche
Synectouche

Reputation: 173

Check column if duplicate record exist in VBA-excel

I'm new to VBA Macro in Excel, and would just like to ask if there's any function for checking duplicate records in excel.

This line of code below removes duplicate referring to column A, but I don't want to actually remove it without user's confirmation, what I wanted to do is to ask for user's confirmation if he wants it to be removed or not, like a popup, and then this line would just execute, but I have no idea if there's a function for checking duplicates. 

ActiveSheet.Range("$A$1:$D$38").RemoveDuplicates Columns:=1

Thanks in advance for your help.

Upvotes: 3

Views: 6441

Answers (1)

tm-
tm-

Reputation: 353

Please try the following code. I've set script to make duplicate cell empty, but you can insert your own code.

Sub FindDuplicates()

    Dim i As Long
    Dim j As Long
    Dim lDuplicates As Long

    Dim rngCheck As Range
    Dim rngCell As Range
    Dim rngDuplicates() As Range

    '(!!!!!) Set your range
    Set rngCheck = ActiveSheet.Range("$A$1:$D$38")

    'Number of duplicates found
    lDuplicates = 0

    'Checking each cell in range
    For Each rngCell In rngCheck.Cells
        Debug.Print rngCell.Address
        'Checking only non empty cells
        If Not IsEmpty(rngCell.Value) Then

            'Resizing and clearing duplicate array
            ReDim rngDuplicates(0 To 0)
            'Setting counter to start
            i = 0

            'Starting search method
            Set rngDuplicates(i) = rngCheck.Find(What:=rngCell.Value, After:=rngCell, LookIn:=xlValues, _
                                                    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)

            'Check if we have at least one duplicate
            If rngDuplicates(i).Address <> rngCell.Address Then

                'Counting duplicates
                lDuplicates = lDuplicates + 1

                'If yes, continue filling array
                Do While rngDuplicates(i).Address <> rngCell.Address
                    i = i + 1
                    ReDim Preserve rngDuplicates(0 To i)
                    Set rngDuplicates(i) = rngCheck.FindNext(rngDuplicates(i - 1))
                Loop

                'Ask what to do with each duplicate
                '(except last value, which is our start cell)
                For j = 0 To UBound(rngDuplicates, 1) - 1
                    Select Case MsgBox("Original cell: " & rngCell.Address _
                                       & vbCrLf & "Duplicate cell: " & rngDuplicates(j).Address _
                                       & vbCrLf & "Value: " & rngCell.Value _
                                       & vbCrLf & "" _
                                       & vbCrLf & "Remove duplicate?" _
                                       , vbYesNoCancel Or vbExclamation Or vbDefaultButton1, "Duplicate found")

                        Case vbYes
                            '(!!!!!!!) insert here any actions you want to do with duplicate
                            'Currently it's set to empty cell
                            rngDuplicates(j).Value = ""
                        Case vbCancel
                            'If cancel pressed then exit sub
                            Exit Sub
                    End Select
                Next j
            End If
        End If
    Next rngCell

    'Final message
    Call MsgBox("Total number of duplicates: " & lDuplicates & ".", vbExclamation Or vbDefaultButton1, Application.Name)

End Sub

P.S. If you need to remove dulpicates only inside one column, you need to adjust rngCheck variable to that particular column.

P.P.S. In my opinion, it's easier to use conditional formatting.

Upvotes: 3

Related Questions