VBA to move all duplicates to another tab

[KGards7]

Hi all,

I have a button that runs the below code:

Sub KGards7()
Dim lr, k As Long
lr = Range("A" & Rows.Count).End(xlUp).Row
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")

For k = lr To 1 Step -1
If dic.Exists(Range("A" & k).Value) = False Then
dic(Range("A" & k).Value) = k
Else: Range("A" & k).EntireRow.Delete
End If
Next k

End Sub

Basically it searches column A locates all duplicates and only keeps the most recent one and deletes the whole row of any of the now outdated duplicates.

My issue is this runs on an Excel document where there are vast quantities of data so to complete it can take on times close to an hour.

Is there a way I can click this button to cut and paste out the duplicates into a new tab, then run the above code on the new tab and then paste the results back into the main tab?

Alternatively if you have another solution so the above code can run faster then I'm open to any and all suggestions.

Thank you, I appreciate your time and help!

 

[lrobbo314]

This seems to work. For testing purposes I had my data in A1:K15. You will most likely need to adjust the first line of code to account for how many columns your data has. Also, I am outputting the duplicates to a sheet called `Dupes`. You'll need to adjust that line of code to suit your needs as well.

Here was my initial test data.

XL
	A	B	C	D	E	F	G	H	I	J	K
1	1	F	V	N	A	G	U	P	R	J	J
2	1	O	B	O	X	U	E	G	L	E	Q
3	2	R	Z	H	Z	T	N	W	F	T	L
4	3	A	G	O	F	S	G	B	N	I	X
5	3	O	P	V	A	M	X	R	Z	E	C
6	4	H	C	F	E	A	U	C	T	N	W
7	5	D	G	W	J	Q	H	F	J	C	W
8	6	L	E	E	W	H	G	J	T	C	K
9	6	X	P	U	D	D	W	S	Y	B	P
10	7	Y	Q	Z	E	D	C	Y	P	P	O
11	8	F	C	A	P	Y	K	L	U	B	O
12	8	I	R	U	K	S	J	H	E	K	G
13	9	N	K	W	Q	I	T	K	D	E	E
14	10	W	A	N	Z	S	H	N	S	V	Q
15	10	Z	R	C	A	O	D	O	G	W	S
Data

Then after running the code.

XL
	A	B	C	D	E	F	G	H	I	J	K
1	1	O	B	O	X	U	E	G	L	E	Q
2	3	O	P	V	A	M	X	R	Z	E	C
3	6	X	P	U	D	D	W	S	Y	B	P
4	8	I	R	U	K	S	J	H	E	K	G
5	10	Z	R	C	A	O	D	O	G	W	S
Data

And then on the 'Dupes' sheet...

XL
	A
1	1
2	3
3	6
4	8
5	10
Dupes

Here's the code.

Sub UNK()
Dim r As Range:         Set r = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Resize(, 11)
Dim AR() As Variant:    AR = r.Value2
Dim SD As Object:       Set SD = CreateObject("Scripting.Dictionary")
Dim DP As Object:       Set DP = CreateObject("Scripting.Dictionary")
Dim UNQ As Object:      Set UNQ = CreateObject("System.Collections.ArrayList")

For i = 1 To UBound(AR)
    If Not SD.exists(AR(i, 1)) Then
        SD(AR(i, 1)) = AR(i, 1)
    Else
        UNQ.Add Application.Index(AR, i, 0)
        DP.Add AR(i, 1), 1
    End If
Next i

r.ClearContents
Range("A1").Resize(UNQ.Count, 11).Value = Application.Transpose(Application.Transpose(UNQ.toArray))
Sheets("Dupes").Range("A1").Resize(DP.Count).Value = Application.Transpose(DP.keys)
End Sub

 

[Fluff]

Roughly how many rows of data do you have?

 

[Fluff]

For large amounts of data, try

Sub KGards7()
   Dim Dic As Object
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, i As Long, NxtCol As Long
   
   Set Dic = CreateObject("Scripting.Dictionary")
   NxtCol = Cells(1, Columns.count).End(xlToLeft).Offset(, 1).Column
   Ary = Range("A2", Range("A" & Rows.count).End(xlUp)).Value2
   ReDim Nary(1 To UBound(Ary), 1 To 1)
   
   For r = 1 To UBound(Ary)
      If Not Dic.Exists(Ary(r, 1)) Then
         Dic.Add Ary(r, 1), Nothing
      Else
         Nary(r, 1) = 1
         i = i + 1
      End If
   Next r
   With Range("A2", Range("A" & Rows.count).End(xlUp)).Resize(, NxtCol)
      .Columns(NxtCol).Value = Nary
      .Sort Cells(2, NxtCol), xlAscending, Header:=xlNo
      .Resize(i).EntireRow.Delete
   End With
End Sub

 

[Fluff]

Had that running the wrong way, it will keep the 1st value not the last.
It should be

Sub KGards7()
   Dim Dic As Object
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, i As Long, NxtCol As Long
   
   Set Dic = CreateObject("Scripting.Dictionary")
   NxtCol = Cells(1, Columns.count).End(xlToLeft).Offset(, 1).Column
   Ary = Range("A2", Range("A" & Rows.count).End(xlUp)).Value2
   ReDim Nary(1 To UBound(Ary), 1 To 1)
   
   For r = UBound(Ary) To 1 Step -1
      If Not Dic.Exists(Ary(r, 1)) Then
         Dic.Add Ary(r, 1), Nothing
      Else
         Nary(r, 1) = 1
         i = i + 1
      End If
   Next r
   With Range("A2", Range("A" & Rows.count).End(xlUp)).Resize(, NxtCol)
      .Columns(NxtCol).Value = Nary
      .Sort Cells(2, NxtCol), xlAscending, Header:=xlNo
      .Resize(i).EntireRow.Delete
   End With
End Sub

 

[KGards7]

Roughly how many rows of data do you have?

There are currently around 17,000 but this is going to grow every day so will be constantly increasing.

 

[Fluff]

Have you tried the code in post#5?

 

[KGards7]

Have you tried the code in post#5?

Hi, yep I tried it this morning on the latest scheduled run and it worked absolutely perfectly and worked instantly!

This is absolutely brilliant thank you so much Fluff!

 

[Fluff]

Glad we could help & thanks for the feedback.

 

[veyselemre]

similar code, get alternative

Sub test()

    Dim rng As Range, i&, ky$, sec(1 To 3)
    With Application
        sec(1) = .ScreenUpdating: .ScreenUpdating = False
        sec(2) = .EnableEvents: .EnableEvents = False
        sec(3) = .Calculation: .Calculation = xlCalculationManual
    End With

    Set rng = Range("A2:A" & Cells(Rows.Count, 1).End(3).Row)
    With CreateObject("Scripting.Dictionary")
        For i = rng.Count To 1 Step -1
            ky = rng(i).Value
            If Not .exists(ky) Then
                .Item(ky) = ""
            Else
                rng(i).Value = ""
            End If
        Next i
    End With
    
    If WorksheetFunction.CountBlank(rng) Then
        rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End If
    
    With Application
        .ScreenUpdating = sec(1)
        .EnableEvents = sec(2)
        .Calculation = sec(3)
    End With
    Beep
End Sub