Remove Duplicates & Blanks in Excel VBA

[Tamiz1982]

Hi,
I want to remove duplicate values and blank cells in excel . I have tried below code.

Sub del_blanks_duplicates()
Dim i, j, lastrow As Long

    Call Activate_Cluster
    lastrow = Cells(Rows.Count, "A").End(xlUp).Row - 1
    For i = lastrow To 1 Step -1
        For j = 1 To i
       
            If (Cells(i, 0) & Cells(i, 1) = Cells(j, 0) & Cells(j, 1)) Or (Cells(i, 0) = "") Then
                MsgBox "The Record is Duplicate / Blanks", vbCritical, Cells(i, 0) + "-A"
                Rows(i).EntireRow.Delete
                Exit For
            End If
        Next j
    Next i
           
End Sub

It shows run time errors.



If have any changes, please guide me.

Thank You....

 

[Trebor76]

Hi Tamiz1982,

The second argument of the Cells function is the column reference which if a number is being used has to have a minimum number of 1 i.e. Col. A. As you have zero Excel errors out.

See how this revised code goes:

Option Explicit
Sub del_blanks_duplicates()

    Dim lngMyRow As Long
    Dim lngLastRow As Long
    
    Application.ScreenUpdating = False

    Call Activate_Cluster
    
    lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row - 1 'Excludes the last cell??
    
    For lngMyRow = lngLastRow To 1 Step -1
        If Len(Range("A" & lngMyRow)) = 0 Or Evaluate("COUNTIF(A:A,A" & lngMyRow & ")") > 1 Then
            MsgBox "The record in row " & lngMyRow & " is either a duplicate or is blank", vbCritical
            Rows(lngMyRow).Delete
            Exit For 'This will stop the process after the first deletion??
        End If
    Next lngMyRow
    
    Application.ScreenUpdating = True
           
End Sub

I've put some questions where I wasn't sure what the logic was.

Regards,

Robert

 

[Tamiz1982]

Thank you for reply....
I want to compare two cells (Registration No & Applicant Name) are same its duplicate & should be deleted also if first column blank cell


i have called function which is active sheet.

lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row - 1 'Excludes the last cell??

Public Sub Activate_Cluster()

    Dim ws As Worksheet
   
   
    If Cluster1.Value = True Then
     
        ThisWorkbook.Sheets("Cluster-1").Activate
        Set ws = ActiveSheet
        ws.Activate
    ElseIf Cluster2.Value = True Then
       
         ThisWorkbook.Sheets("Cluster-2").Activate
         Set ws = ActiveSheet
        ws.Activate
    Else
       
        ThisWorkbook.Sheets("Cluster-3").Activate
        Set ws = ActiveSheet
        ws.Activate
       
    End If
   
End Sub

 

[Trebor76]

Try this (though initially on a copy of your data as the results cannot be undone if they are not as expected):

Option Explicit
Sub Macro1()

    Dim lngMyRow As Long
    Dim lngLastRow As Long
    Dim cln As New Collection
    Dim strMyKey As String
    
    Application.ScreenUpdating = False
    
    lngLastRow = Range("D:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For lngMyRow = lngLastRow To 1 Step -1
        strMyKey = Trim(Range("D" & lngMyRow)) & Trim(Range("E" & lngMyRow))
        If Len(strMyKey) = 0 Then
            Rows(lngMyRow).Delete
        Else
            On Error Resume Next
                cln.Add strMyKey, CStr(strMyKey)
                If Err.Number <> 0 Then
                    Rows(lngMyRow).Delete
                End If
            On Error GoTo 0
        End If
    Next lngMyRow
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[Tamiz1982]

Thanks for reply. But it is delete if Registration No entered.

If Registration No same but Applicant Name is different it should be accepted . How to do....?

 

[Trebor76]

Not sure what you mean

The code joins D and E and will delete any row if:

1. The length of the join is zero (i.e. columns D and E had no entries)
2. The join has a duplicate (the first is kept)

 

[Tamiz1982]

Its working but it does not delete entire row only also remaining rows deleted which i have applied formulas.

my input column is A & B others are applied formulas based on inputs.
Sorry for incontinence.....
Before :

After

 

[Trebor76]

You've lost me I'm afraid

Hopefully someone else in the forum will be able to help

 

[Tamiz1982]

Thank you for your Patience.
Manually i checked with help of separate new workbook. Its working. Usually looking into your coding, its worked.
But in my workbook I have another sheet which is linked it. I found & correct it.
Sorry for taken your lots of time, please.
Again Thanks a lot....?

 

[Trebor76]

You're welcome. I'm glad we were able to provide a workable solution