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"

 

[Legacy 143009]

Hi,

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

Have a nice day

Sub RemoveDubs()
    ActiveSheet.Range("$A:$A").RemoveDuplicates Columns:=1, Header:=xlYes
End Sub

 

[Peter_SSs]

Hi,

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

Can you confirm ..
- Whether or not you have other columns of data on the sheet and, if so, if you want the entire row removed from the sheet for duplicates in column A?
- Whether your data has headings or not?
- About how many rows of data are you likely to have in your sheet?
- For the sample below, whether you want rows 3:7 all deleted or just rows 5:7, leaving a single occurrence of each value?

Book1
	A
1	Hdr 1
2	a
3	b
4	c
5	b
6	c
7	c
8	d
Delete Dupes

 

[manoj_arsul]

Hi @Peter_SSs

Thank u for your reply !!!

I want run program for below data

A B C
1 A X
2 B y
1 C Z
2 D a
5 E b
1 G C
3 H G
4 I H
1 J I

Output :
A B C
1 A X
2 B y
5 E b
3 H G
4 I H

 

[Peter_SSs]

I want run program for below data

OK, try this with a copy of your workbook.

Sub RemoveDupes()
  Dim d As Object
  Dim a, b
  Dim nc As Long, i As Long, k As Long
  
  Set d = CreateObject("SCripting.Dictionary")
  nc = Cells.Find(What:="*", After:=Cells(1, 1), LookIn:=xlValues, SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, SearchFormat:=False).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 Sub

 

[Legacy 143009]

Hi @Peter_SSs

Thank u for your reply !!!

I want run program for below data

A B C
1 A X
2 B y
1 C Z
2 D a
5 E b
1 G C
3 H G
4 I H
1 J I

Output :
A B C
1 A X
2 B y
5 E b
3 H G
4 I H

Sub RemoveDubs()
    ActiveSheet.Range("$A:$A").RemoveDuplicates Columns:=3, Header:=xlNo
End Sub

 

[Peter_SSs]

Sub RemoveDubs()
    ActiveSheet.Range("$A:$A").RemoveDuplicates Columns:=3, Header:=xlNo
End Sub

Have you run that successfully? It just errors for me.

 

[manoj_arsul]

Hi @Peter_SSs

Thank u Sooo Much !!!!

 

[manoj_arsul]

Its not running for me too. I also got an error

 

[manoj_arsul]

OK, try this with a copy of your workbook.

Sub RemoveDupes()
  Dim d As Object
  Dim a, b
  Dim nc As Long, i As Long, k As Long
  
  Set d = CreateObject("SCripting.Dictionary")
  nc = Cells.Find(What:="*", After:=Cells(1, 1), LookIn:=xlValues, SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, SearchFormat:=False).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 Sub

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