Delete duplicates cells

[MayHmne]

I have tried the below macro and it is working but when applying it on a larger range of data (specifically 17137 rows) a considerable amount of data are deleted not just the duplicates

RemoveDupes add blank
Sub RemoveDupes()
Dim X As Long
For X = 1 To Range("A" & Rows.Count).End(xlUp).Row
If Application.WorksheetFunction.CountIf(Range("A1:A" & X), Range("A" & X).Text) > 1 Then Rows(X).ClearContents
Next
End Sub

so, any other codes that solve this issue?

 

[Logit]

I don't know what to advise. The macro functions here.

????

 

[Logit]

.
Here is a different approach :

Option Explicit

Sub DeleteDups()
    
    Dim x               As Long
    Dim LastRow         As Long
    Dim Cells           As Range
    Application.ScreenUpdating = False
    With ActiveSheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        LastRow = LastRow
    End With
 
    For x = LastRow To 1 Step -1
        If Application.WorksheetFunction.CountIf(Range("A1:A" & x), Range("A" & x).Text) > 1 Then
            Range("A" & x).EntireRow.Delete
        End If
    Next x
    Application.ScreenUpdating = True
    
End Sub

 

[MayHmne]

The macro is designed to check column A : Range("A1")

If you are checking a different column for the duplicates, change the A to the other column letter.

The macro is designed to check column A : Range("A1")

If you are checking a different column for the duplicates, change the A to the other column letter.

unfortunately, another error appears

 

[MayHmne]

I

.
Here is a different approach :

Option Explicit

Sub DeleteDups()
   
    Dim x               As Long
    Dim LastRow         As Long
    Dim Cells           As Range
    Application.ScreenUpdating = False
    With ActiveSheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        LastRow = LastRow
    End With

    For x = LastRow To 1 Step -1
        If Application.WorksheetFunction.CountIf(Range("A1:A" & x), Range("A" & x).Text) > 1 Then
            Range("A" & x).EntireRow.Delete
        End If
    Next x
    Application.ScreenUpdating = True
   
End Sub

This one works, but it doesn't enter empty rows instead for cells that have been deleted

 

[Logit]

Option Explicit

Sub DeleteDups()
    
    Dim x               As Long
    Dim LastRow         As Long
    Dim Cells           As Range
    
    Dim lRow            As Variant
    
    Application.ScreenUpdating = False
    With ActiveSheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        LastRow = LastRow
    End With
 
    For x = LastRow To 1 Step -1
        If Application.WorksheetFunction.CountIf(Range("A1:A" & x), Range("A" & x).Text) > 1 Then
            Range("A" & x).EntireRow.Delete
        End If
    Next x
    
    With ActiveSheet
            lRow = .Range("A" & .Rows.Count).End(xlUp).Row
            .Range("A1:A" & lRow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
        
    Application.ScreenUpdating = True
    
End Sub