Fastest method to move duplicates from to a new sheet

[logandiana]

I have looked and tried several ways to identify duplicates and copy them to a new sheet.
I have about 20,000 lines in columns A:J. If there are duplicates in column E, then I want move the entire row (both original and duplicate) to the new sheet.

I've used VBA to add a countif formula to column K, then turn it to values, autofilter on greater than 1, then copy and paste to the destination sheet.
This is the method I am currently using but it does slow the macro down almost by 45 seconds or so.

With MM
.Range("K2:K" & LR1).FormulaR1C1 = "=COUNTIF(R2C5:R" & LR1 & "C5,RC[-6])"
.Range("K2:K" & LR1).Value = .Range("K2:K" & LR1).Value
.Range("A1:K" & LR1).AutoFilter , Field:=11, Criteria1:=">1"
.Range("A1:J" & LR1).Copy Destination:=DUPS.Range("A1")
End With

I've tried some other methods using conditional formatting to identify dups with a color, then using loops and IF THEN to check each cell, but this portion takes several minutes.

Any other ideas that could accomplish what I am wanting to do much faster?

 

[Fluff]

How about

Sub logandiana()
   Dim Cl As Range, Rng As Range
   Dim Ws As Worksheet
   
   Set Ws = Sheets("[COLOR=#ff0000]Pcode[/COLOR]")
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws.Range("E2", Ws.Range("E" & Rows.Count).End(xlUp))
         If Not .Exists(Cl.Value) Then
            .Add Cl.Value, Cl.Offset(, -4).Resize(, 10)
         Else
            If Rng Is Nothing Then Set Rng = Union(Cl.Offset(, -4).Resize(, 10), .Item(Cl.Value)) Else Set Rng = Union(Rng, Cl.Offset(, -4).Resize(, 10), .Item(Cl.Value))
         End If
      Next Cl
   End With
   If Not Rng Is Nothing Then Rng.Copy Sheets("[COLOR=#ff0000]Sheet1[/COLOR]").Range("A1")
End Sub

Change sheet names to suit

 

[logandiana]

How about

Sub logandiana()
   Dim Cl As Range, Rng As Range
   Dim Ws As Worksheet
   
   Set Ws = Sheets("[COLOR=#ff0000]Pcode[/COLOR]")
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws.Range("E2", Ws.Range("E" & Rows.Count).End(xlUp))
         If Not .Exists(Cl.Value) Then
            .Add Cl.Value, Cl.Offset(, -4).Resize(, 10)
         Else
            If Rng Is Nothing Then Set Rng = Union(Cl.Offset(, -4).Resize(, 10), .Item(Cl.Value)) Else Set Rng = Union(Rng, Cl.Offset(, -4).Resize(, 10), .Item(Cl.Value))
         End If
      Next Cl
   End With
   If Not Rng Is Nothing Then Rng.Copy Sheets("[COLOR=#ff0000]Sheet1[/COLOR]").Range("A1")
End Sub

Change sheet names to suit

Thank you Fluff! Amazing I can't quite yet wrap my brain around how this even works yet, but it's almost instantaneous.

One further question, is there a way CUT these from the original while copying to the new sheet? I tried

If Not Rng Is Nothing Then Rng.[COLOR=#FF0000]Cut[/COLOR] Sheets("DUPS").Range("A1")

but couldn't make it work.

 

[Fluff]

Do you want to delete those cells & shift everything up?

 

[logandiana]

Do you want to delete those cells & shift everything up?

Yes I'd like to move duplicate rows to the new sheet (which your code does). And delete them from the original sheet and yes, shift everything up.

 

[Fluff]

In that case use

   If Not Rng Is Nothing Then
      Rng.Copy Sheets("DUPS").Range("A1")
      Rng.Delete xlShiftUp
   End If

 

[logandiana]

In that case use

   If Not Rng Is Nothing Then
      Rng.Copy Sheets("DUPS").Range("A1")
      Rng.Delete xlShiftUp
   End If

Wow!, again I have no understanding of how this works, but thanks!!

 

[Fluff]

You're welcome & thanks for the feedback