VBA Help Speed up Dupe Code

Stephen_IV

Well-known Member
Joined
Mar 17, 2003
Messages
1,168
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
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!


Code:
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
 

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().
I'd suggest you record a macro that autofilters the From worksheet for column A > 1, then copies visible cells to the To sheet.
 
Upvote 0
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.
Code:
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
 
Upvote 0
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!
 
Upvote 0
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?
Code:
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
 
Last edited:
Upvote 0
kalak! Thank you so much! That was it! I appreciate all of your help! Thanks again!
 
Upvote 0

Forum statistics

Threads
1,213,527
Messages
6,114,148
Members
448,552
Latest member
WORKINGWITHNOLEADER

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top