Help to faster this script for moving Duplicates

[zmagic]

Hi,

The below codes works very slow and hangs finally not responding, some one help me to make faster for 3,00,000 rows. Or alternate script to achieve the result.

Search the duplicates entries in column A and its original row moved to Sheet2.

Option Explicit


Sub CUT_Dupes_New_Sheet()
    
    On Error GoTo ErrHandler
    
    Dim myDataRng As Range, myCutRng As Range
    Dim c As Range, cc As Range
    Dim lCol As Long
     
    Set myDataRng = Range("A2:A" & Cells(Rows.Count, "I").End(xlUp).Row)
 
    Application.ScreenUpdating = False
     
    For Each c In myDataRng
    
        If Application.Evaluate("COUNTIF(" & myDataRng.Address & "," & c.Address & ")") > 1 Then
            lCol = Cells(c.Row, Columns.Count).End(xlToLeft).Column
            c.Offset(, 17) = "xx"
        End If
        
    Next c
     
     Set myCutRng = Range("R2:R" & Cells(Rows.Count, "I").End(xlUp).Row)
       
    For Each cc In myCutRng
        If cc = "xx" Then
            cc.Offset(, -17).Resize(1, 17).Cut Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp)(2)
        End If
    Next cc
     
    Set myDataRng = Nothing
    Range("R:R").ClearContents
    
ErrHandler:
  
    Application.ScreenUpdating = True
End Sub

Posted at windowssecrets.com

[p45cal]

I think it can be speeded up, but could you:

• supply a file with a few hundred rows where there'll need to be several move operations
• supply a more accurate link to your windowssecrets thread (miss off the http bit if this site doesn't let you post links yet)

[zmagic]

Hi,

Thanks p45cal for response.

Sample database file uploaded.

Posted at : windowssecrets.com/forums/showthread.php/195501-Move-Duplicates

Thanks.

[offthelip]

One of the main reasons that Vba is slow is the time taken to access the worksheet from VBa is a relatively long time.
To speed up vba the easiest way is to minimise the number of accesses to the worksheet. What is interesting is that the time taken to access a single cell on the worksheet in vba is almost identical as the time taken to access a large range if it is done in one action.
So instead of writing a loop which loops down a range looking one row at a time which will take along time if you have got 50000 rows it is much quicker to load the 50000 lines into a variant array ( one worksheet access), then do the calculation on the variant array. So I have changed your calculation on how to detect the duplicates by loading the range into a variant array and doing it all in memory, then when doing the actually moving the rows I have done it in reverse order because I think EXCEL might be faster starting at the bottom because it has fewer rows to move up.
If your spreadsheet only contains data and doesn't have any equatoins then this step can also be done using variant arrays, which would mean the whole thing would take less than a second for thousands of rows.


I have a simple rule for fast VBA: NEVER ACCESS THE WORKSHEET IN A LOOP.

I have to say this on this forum so many times that I now keep a copy ready to paste into the forum.

So try this (untested)

Sub test()
    Dim mydatarange As Variant
    Dim duplicates() As Boolean
    Dim cc As Range
    
      lastrow = Cells(Rows.Count, "I").End(xlUp).Row
      ReDim duplicates(1 To lastrow)
      myDataRng = Range("A2:A" & lastrow)
     ' initialise duplicates flags
     For i = 1 To lastrow
      duplicates(i) = False
     Next i
 '   Application.ScreenUpdating = False
     ' loop to find duplicates
    For i = 1 To lastrow
         For j = i To lastrow
            If myDataRng(i, 1) = myDataRng(j, 1) Then
             duplicates(i) = True
             Exit For
            End If
         Next j
    Next i
    For i = lastrow To i Step -1
     If duplicates(i) Then
           Set cc = Range(Cells(i, 1), Cells(i, 17))
            cc.Cut Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp)(2)
      End If
    Next i
     
         
   Application.ScreenUpdating = True


End Sub

[p45cal]

Aother take. Try this on the active sheet. See comments within the code, especially about Column I:

Sub blah()
Set myDataRng = Range("A1:A" & Cells(Rows.Count, "I").End(xlUp).Row)  '(1) unqualified so works on active sheet (2) Column I is blank in your sample sheet so you may need to adjust this line.
With myDataRng
  Set yyy = .FormatConditions.AddUniqueValues
  yyy.SetFirstPriority
  yyy.DupeUnique = xlDuplicate
  yyy.Interior.Color = 16776959  'a colour hardly visible so unlikely to have been used for any sort of highlighting.
  .AutoFilter Field:=1, Criteria1:=16776959, Operator:=xlFilterCellColor
  Set rngToCopy = Intersect(myDataRng, .Offset(1)).Resize(, 8).SpecialCells(xlCellTypeVisible)
  yyy.Delete
  .AutoFilter
End With
rngToCopy.Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp)(2)  'OR the two lines below for a new sheet.
'  Set NewSht = Sheets.Add(After:=Sheets(Sheets.Count))
'  rngToCopy.Copy NewSht.Cells(1)
rngToCopy.Delete Shift:=xlUp
End Sub

There may be a limitation on how many non-contiguous areas can be processed - but I think you'll be lucky.