Copy all Duplicates to the bottom of Active sheet

[Papercut]

Hello,

I have searched and found this code to move the macros to another sheet, but I sort of modified it to move to the bottom of the activesheet.

My question is how do I stop so many blank rows from coming between my last row of data and the duplicates?

And more importantly, how do I modify the code to copy both duplicates to the bottom? Right now it is only copying just one.

I usually have files with upwards of 10k rows so other other code on here doesn't seem to work for that many rows and takes a long time with the loops.

Any help would be appreciated.

Thanks

 Sub MoveDupesB()

Dim t As Single


Dim d As Object, x&, xcol As String
Dim lc&, lr&, k(), e As Range
t = Timer


xcol = "B"


lc = Cells.Find("*", after:=[a1], searchdirection:=xlPrevious).Column
lr = Cells.Find("*", after:=[a1], searchdirection:=xlPrevious).Row
ReDim k(1 To lr, 1 To 1)


Set d = CreateObject("scripting.dictionary")
For Each e In Cells(1, xcol).Resize(lr)
    If Not d.exists(e.Value) Then
        d(e.Value) = 1
        k(e.Row, 1) = 1
    End If
Next e
If d.Count = lr Then
    MsgBox "No duplicates"
    Exit Sub
End If


Cells(1, lc + 1).Resize(lr) = k
Range("A1", Cells(lr, lc + 1)).Sort Cells(1, lc + 1), 1
x = Cells(1, lc + 1).End(4).Row
Cells(x + 1, 1).Resize(lr - x, lc).Copy ActiveSheet.Range("A" & lr)
Cells(x + 1, 1).Resize(lr - x, lc).Clear
Cells(1, lc + 1).Resize(x).Clear
MsgBox "Code took " & Format(Timer - t, "0.00 secs")
MsgBox lr & " rows" & vbLf & lc & " columns" & vbLf & _
    lr - x & " duplicate rows"


End Sub

 

[dangelor]

Possibly... it worked on a very small worksheet

 Sub MoveDupesB()
    
    'Assumes data range begins in column A
    
    Dim v As Variant
    Dim x As Long
    Dim y As Long
    Dim d As Object
    Dim key As Variant
    Dim r As Range
    
    Set d = CreateObject("scripting.dictionary")
    
    With ActiveSheet
        v = .UsedRange
        For x = LBound(v) To UBound(v) - 1
            For y = x + 1 To UBound(v)
                If v(x, 2) = v(y, 2) Then
                    If Not d.exists(v(x, 1)) Then
                        d(v(x, 1)) = x
                        d(v(y, 1)) = y
                    End If
                End If
            Next y
        Next x
        
        For Each key In d.Keys
            If Not r Is Nothing Then
                Set r = Union(r, .Rows(d(key)))
            Else
                Set r = .Rows(d(key))
            End If
        Next key
        r.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(3)
    End With
End Sub

 

[Papercut]

Thank you so much, this works well. Is there a way to cut the cells or remove the rows in the main data once they have been copied to the bottom?

 

[Papercut]

Nevermind figured it out. Works exactly like i hoped. Thank you again!!

 

[dangelor]

Glad to help!

 

[Papercut]

Hello,

Sorry to bother you again, but is there an easy way to modify the code to look for all occurrences and not just duplicates? I have a different data set that may have up to 5 occurrences. If not maybe, up to 5 occurrences?

Again.

Thank you