KLUDGE FIX Speed this section of code

[mole999]

Problem, I need to identify exact duplicates so I can remove them

I have

    Application.ScreenUpdating = False
    With ActiveSheet
        .Range("AM2").FormulaR1C1 = _
        "=IF(COUNTIF(R2C36:R" & LR & "C36,RC[-3])>1,IF(COUNTIF(R2C[-3]:RC[-3],RC[-3])=1,"""",""Duplicate""),"""")"
        .Range("Am2").Select
        Selection.AutoFill Destination:=.Range("Am2:Am" & LR)
        .Range("Am2:Am" & LR).Select
    End With
    Application.ScreenUpdating = True

=IF(COUNTIF($AJ$2:$AJ$67596,AJ9)>1,IF(COUNTIF(AJ$2:AJ2,AJ2)=1,"","Duplicate"),"")

but it is currently doing over hundred thousand rows, and as its volatile its taking forever (well tens of minutes)

any quick fix that would do the same but place the static value DUPLICATE in the right place. I've tried multiple different ways, this worked on small test sets. I can then get on with working with the cut down data

Pretty Please

 

[steve the fish]

Does this help?

Dim lr As Long, rng As Variant, myRng As Range, d As Object, i As Long
lr = Range("AJ" & Rows.Count).End(xlUp).Row
rng = Range("AJ2:AJ" & lr)
Set d = CreateObject("Scripting.Dictionary")
With d
    For i = 1 To UBound(rng, 1)
        If d.Exists(rng(i, 1)) Then
            If Not myRng Is Nothing Then
                Set myRng = Union(myRng, Rows(i + 1))
            Else
                Set myRng = Rows(i + 1)
            End If
        Else
            d(rng(i, 1)) = 1
        End If
        
    Next i
End With
myRng.Select
'myRng.EntireRow.Delete Shift:=xlUp
Set d = Nothing

 

[mole999]

Had to stop it after 30 minutes plus, with no visible result, so I don't know if in the long run this is the most optimal way to go

Yes I did turn of screenupdating, well the second time as I forgot

 

[steve the fish]

That took 30 minutes just running that piece of code on its own? Don't do any deleting. How long does it take then?

 

[mole999]

I ran this

[COLOR=#FF0000]Sub test()
Dim a, b, c
a = Now()
Application.ScreenUpdating = False
Dim lr As Long, rng As Variant, myRng As Range, d As Object, i As Long
lr = Range("AJ" & Rows.Count).End(xlUp).Row
rng = Range("AJ2:AJ" & lr)
Set d = CreateObject("Scripting.Dictionary")
With d
    For i = 1 To UBound(rng, 1)
        If d.Exists(rng(i, 1)) Then
            If Not myRng Is Nothing Then
                Set myRng = Union(myRng, Rows(i + 1))
            Else
                Set myRng = Rows(i + 1)
            End If
        Else
            d(rng(i, 1)) = 1
        End If
        
    Next i
End With
Application.ScreenUpdating = True
    
myRng.Select
  b = Now()
    c = b - a
Call MsgBox(Format(c, "hh:mm:ss"), vbExclamation, Application.Name)
'myRng.EntireRow.Delete Shift:=xlUp
Set d = Nothing
End Sub[/COLOR]

It never reported getting to the Msgbox.

I'm not familiar with the scripting dictionary, did I mention its 105171 rows currently

 

[steve the fish]

Im struggling. Ive just run that on a million cells. It took 10 seconds and correctly selected duplicate cells. Put the spreadsheet on dropbox or something so I could look maybe?

 

[B___P]

Hi mole what about this

Sub mole()
Dim myrange As Range
Dim lastrow As Long
lastrow = Range("AJ" & Rows.Count).End(xlUp).Row
Set myrange = Range(Cells(2, 36 + 3), Cells(lastrow, 36 + 3))
Application.Calculation = xlCalculationManual

myrange.Formula = "=IF(COUNTIF($AJ$2:$AJ2,AJ2)>1,IF(COUNTIF(AJ$2:AJ2,AJ2)=1,"""",""Duplicate""),"""")"
myrange.Value = myrange.Value
Application.Calculation = xlCalculationAutomatic
End Sub

turn screenupdating false if you want...

cheers

 

[mole999]

full restart, and no joy, killed and looking through with F8, d and I are incrementing as would be expected. I have no idea why its not getting to completion. AJ is a formula =M2&IF(AND(X2<>"",Y2<>""),"A",IF(AND(LEFT(X2,1)="B",Y2=""),"B",IF(O2="NO ACTIVE LICENCE RECORDED","D",IF(AND(LEFT(Y2,2)="C1",X2=""),"E","C")))).

No other formulas, converted that to a value as it only needed to be set once. Can't post the files as its Personnel/Data Protection (and I don't have a fake set), and I'm not going to try and obfuscate it. Tried again and killed after 10 minutes

5000 rows took 6 seconds

 

[mole999]

Hi mole what about this

Sub mole()
Dim myrange As Range
Dim lastrow As Long
lastrow = Range("AJ" & Rows.Count).End(xlUp).Row
Set myrange = Range(Cells(2, 36 + 3), Cells(lastrow, 36 + 3))
Application.Calculation = xlCalculationManual

myrange.Formula = "=IF(COUNTIF($AJ$2:$AJ2,AJ2)>1,IF(COUNTIF(AJ$2:AJ2,AJ2)=1,"""",""Duplicate""),"""")"
myrange.Value = myrange.Value
Application.Calculation = xlCalculationAutomatic
End Sub

turn screenupdating false if you want...

cheers

very subtle on the last row in the formula, still takes a longish while to run and doesn't hard code the value, I still have the formula

=IF(COUNTIF($AJ$2:$AJ158,AJ158)>1,IF(COUNTIF(AJ$2:AJ158,AJ158)=1,"","Duplicate"),"")

I know there is a way of doing this (quicklyish)

 

[jkpieterse]

What about:

Sub GetRidOfDups()
    Range("AJ1").CurrentRegion.RemoveDuplicates Columns:=Range("AJ1").Column - Range("AJ1").CurrentRegion.Cells(1, 1).Column + 1 _
    , Header:=xlYes
End Sub