VBA Help Speed up Dupe Code

[Stephen_IV]

Good afternoon,

I have code below that copies duplicates to sheet2. The code works find but is slow. Does anyone have any other way or code that is faster? Thanks in advance! With over 100,000 rows it is slow!

Sub Dupe()
   Sub Dupe()
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Set sh1 = Sheets(1)
    Set sh2 = Sheets(2)
    Dim lastRow As Long
    Dim i As Long
    Dim addrow As Long

    lastRow = sh1.Cells(Rows.Count, "A").End(xlUp).Row
    addrow = sh2.Cells(Rows.Count, "A").End(xlUp).Row + 1
    Set r = Range("a1:a" & lastRow)
    
    For Each mcell In r
         If WorksheetFunction.CountIf(r, mcell) > 1 Then
             mcell.Copy sh2.Range("A" & addrow)
             mcell.Offset(0, 1).Copy sh2.Range("B" & addrow)
             addrow = addrow + 1
         End If
    Next mcell
End Sub

 

[shg]

I'd suggest you record a macro that autofilters the From worksheet for column A > 1, then copies visible cells to the To sheet.

 

[kalak]

If you're just interested in transferring duplicated values and not formats then the following code could be fast enough for you with 100,000+ lines.
If you want formats transferred as well then that can be done too, but need clarify if you regard the same value but a different format( or vice versa) as duplicated.

Sub dupe2()
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Set sh1 = Sheets(1)
    Set sh2 = Sheets(2)
    Dim i As Long, c As Long
    Dim dic As Object
    Dim X, r
    
    Set dic = CreateObject("scripting.dictionary")
    r = Range("a1:a" & Cells(Rows.Count, "a").End(xlUp).Row)
    ReDim X(1 To UBound(r), 1 To 1)
    For Each q In r
         dic(q) = dic(q) + 1
    Next
    
    For Each q In r
        If dic(q) > 1 Then c = c + 1: X(c, 1) = q
    Next
    
   sh2.Range("B1").Resize(c) = X

End Sub

 

[Stephen_IV]

kalak,

Thank you very much that was fast and yes it did bring the dupes over but I need bring the dupe value over and the value next to it, the offset(,1). Any help would be appreciated. Thank you in advance!

 

[kalak]

kalak,

Thank you very much that was fast and yes it did bring the dupes over but I need bring the dupe value over and the value next to it, the offset(,1). Any help would be appreciated. Thank you in advance!

Like this?

Sub dupe3()
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Set sh1 = Sheets(1)
    Set sh2 = Sheets(2)
    Dim i As Long, c As Long
    Dim dic As Object
    Dim X, r
    
    Set dic = CreateObject("scripting.dictionary")
    r = Range("a1:b" & Cells(Rows.Count, "a").End(xlUp).Row)
    ReDim X(1 To UBound(r), 1 To 2)
    For i = 1 To UBound(r)
         dic(r(i, 1)) = dic(r(i, 1)) + 1
    Next
    
    For i = 1 To UBound(r)
        If dic(r(i, 1)) > 1 Then
            c = c + 1
            X(c, 1) = r(i, 1)
            X(c, 2) = r(i, 2)
        End If
    Next
    
   sh2.Range("A1").Resize(c, 2) = X


End Sub

 

[Stephen_IV]

kalak! Thank you so much! That was it! I appreciate all of your help! Thanks again!