PDA

View Full Version : [SOLVED] Help to faster this script for moving Duplicates



zmagic
02-04-2018, 02:32 PM
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
02-04-2018, 03:51 PM
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
02-04-2018, 08:19 PM
Hi,

Thanks p45cal for response.

Sample database file uploaded.

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

Thanks.

offthelip
02-05-2018, 03:10 AM
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
02-05-2018, 07:11 AM
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.