Check duplicates in one coloumn and delete duplicate row

[manoj_arsul]

Hi,

I want to run program for find duplicate values in column "A" , & delete all those row which are duplicates values in Column "A"

 

[Peter_SSs]

Hi @Peter_SSs

Thank u Sooo Much !!!!

You are very welcome.

also one request , If i want run this program on different sheet then ,

eg. I am on sheet1 and i want run this program for sheet2 or sheet3

Try

Sub RemoveDupes()
  Dim d As Object
  Dim a, b
  Dim nc As Long, i As Long, k As Long
  
  With Sheets("Sheet6")                         '<- Set your sheet name here
    Set d = CreateObject("SCripting.Dictionary")
    nc = .Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
    a = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Value
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
      If d.exists(a(i, 1)) Then
        b(i, 1) = 1
        k = k + 1
      Else
        d(a(i, 1)) = 1
      End If
    Next i
    If k > 0 Then
      Application.ScreenUpdating = False
      With .Range("A1").Resize(UBound(a), nc)
        .Columns(nc).Value = b
        .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
        .Resize(k).EntireRow.Delete
      End With
      Application.ScreenUpdating = True
    End If
  End With
End Sub

BTW, about how many rows do you have in your real data?

 

[manoj_arsul]

You are very welcome.

Try

Sub RemoveDupes()
  Dim d As Object
  Dim a, b
  Dim nc As Long, i As Long, k As Long
  
  With Sheets("Sheet6")                         '<- Set your sheet name here
    Set d = CreateObject("SCripting.Dictionary")
    nc = .Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
    a = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Value
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
      If d.exists(a(i, 1)) Then
        b(i, 1) = 1
        k = k + 1
      Else
        d(a(i, 1)) = 1
      End If
    Next i
    If k > 0 Then
      Application.ScreenUpdating = False
      With .Range("A1").Resize(UBound(a), nc)
        .Columns(nc).Value = b
        .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
        .Resize(k).EntireRow.Delete
      End With
      Application.ScreenUpdating = True
    End If
  End With
End Sub

BTW, about how many rows do you have in your real data?

Thank u peter , In Real data I have more than 50000 rows

 

[manoj_arsul]

Hi @Peter_SSs

I have the below program for delete row if specific value content in column . but it getting too much time for running .

I want to run the same program but take less time.

Also help me for the run that program for different sheet (Sheet2)



Sub DeleteRowContents()

last = Cells(Rows.Count, "G").End(xlUp).Row
For i = last To 1 Step -1
If (Cells(i, "G").Value) = "ABCD" Then
Cells(i, "A").EntireRow.Delete
End If
Next i
For i = last To 1 Step -1
If (Cells(i, "G").Value) = "XYZ" Then
' Cells(i, "A").EntireRow.Delete
End If
Next i
For i = last To 1 Step -1
If (Cells(i, "G").Value) = "PQR" Then
Cells(i, "A").EntireRow.Delete
End If

Next i

End Sub

 

[manoj_arsul]

Hi @Peter_SSs

I have the below program for delete row if specific value content in column . but it getting too much time for running .

I want to run the same program but take less time.

Also help me for the run that program for different sheet (Sheet2)



Sub DeleteRowContents()

last = Cells(Rows.Count, "G").End(xlUp).Row
For i = last To 1 Step -1
If (Cells(i, "G").Value) = "ABCD" Then
Cells(i, "A").EntireRow.Delete
End If
Next i
For i = last To 1 Step -1
If (Cells(i, "G").Value) = "XYZ" Then
' Cells(i, "A").EntireRow.Delete
End If
Next i
For i = last To 1 Step -1
If (Cells(i, "G").Value) = "PQR" Then
Cells(i, "A").EntireRow.Delete
End If

Next i

End Sub

@Peter_SSs I got the code for this Thank u

 

[Peter_SSs]

I am a little confused by your last few posts. Do you have everything you want now?