Help with slow macro

[JadonR]

I am using the following macro to delete entire duplicate lines. The duplicate are found in column Q. I have data all the way to column AH.

Sub RemoveALLDuplicates()
With Application
    .EnableEvents = False
    .ScreenUpdating = False
    PrevCalc = .Calculation
    .Calculation = xlCalculationManual
End With
    'Application.ScreenUpdating = False
    Dim r As Range, txt As String
    With CreateObject("Scripting.Dictionary")
Again:
        For Each r In Range("Q1", Range("Q" & Rows.Count).End(xlUp))
            If Not .exists(r.Value) Then
                .Add r.Value, Nothing
            Else
                txt = txt & "," & r.Address(0, 0)
                If Len(txt) > 245 Then
                    Intersect(Range(Mid(txt, 2)).EntireRow, Columns("B:IV")).Delete
                    .RemoveAll
                    txt = Empty: GoTo Again
                End If
            End If
        Next
    End With
    If Len(txt) Then Intersect(Range(Mid(txt, 2)).EntireRow, Columns("B:IV")).Delete
    'Application.ScreenUpdating = True
    With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .Calculation = PrevCalc
End With
End Sub

However, it is extremely slow and can take more than an hour when I sometimes have close to 30,000 rows. Is there a way I can speed this up?

 

[Dannyh1]

Hi Try

At the top of your code:

Sub RemoveALLDuplicates()

Application.DisplayAlerts = False
Application.ScreenUpdating = False
ApplicationEnableEvents = False

At bottom of your code

End With
 
Application.DisplayAlerts = True
Application.ScreenUpdating = True
ApplicationEnableEvents = True
 
End Sub

 

[JadonR]

Thanks Dannyh1, but that doesn't seem to help. It's been more than 30 minutes and it still hasn't finished. What about using the Remove Duplicates built into Excel 2007? I'm especially concerned that it won't delete the entire row (I am choosing "Expand the selection"), and I'll be left with incorrect rows. Anyway, I recorded that as a macro, and now I have the following:

Sub RemoveALLDuplicates()
    Application.ScreenUpdating = False
Application.CutCopyMode = False
    Columns("Q:Q").Select
    ActiveSheet.Range("$A$1:$AH$30000").RemoveDuplicates Columns:=17, Header:= _
        xlYes

    Application.ScreenUpdating = True
End Sub

It takes less than a minute. Any reason why this wouldn't work?

 

[Dannyh1]

Hi,

Maybe try using a filter, something along the lines of:

Dim rng As Range
Set rng = Sheets[I]("sheetname").[/I]Range("A1:AH30000").SpecialCells(xlCellTypeVisible)
 
[I][COLOR=lime]turn on you filter here[/COLOR][/I]
 
rng.select
Selection.EntireRow.Delete

 

[Peter_SSs]

JadonR

What version of Excel are you using?

 

[JadonR]

Thanks Dannyh1, I'll give that a try.

@Peter_SSs, I'm using both 2003 and 2007, so I would prefer it to work with either.

 

[Peter_SSs]

I would prefer it to work with either.

Pity, for 2007+ I think all you need is this. My assumption is you have a header row.

<font face=Courier New><br><SPAN style="color:#00007F">Sub</SPAN> RemoveDuplicates2007()<br>    <SPAN style="color:#00007F">Dim</SPAN> lr <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <br>    lr = Range("Q" & Rows.Count).End(xlUp).Row<br>    Range("A1:AH" & lr).RemoveDuplicates Columns:=17, Header:=xlYes<br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>


To include earlier versions, and using your code as a basis, try this (in a copy of your workbook).

<font face=Courier New><br><SPAN style="color:#00007F">Sub</SPAN> RemoveALLDuplicates()<br>    <SPAN style="color:#00007F">With</SPAN> Application<br>        .EnableEvents = <SPAN style="color:#00007F">False</SPAN><br>        .ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br>        PrevCalc = .Calculation<br>        .Calculation = xlCalculationManual<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> r <SPAN style="color:#00007F">As</SPAN> Range, txt <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> lr <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, i <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, x <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> a, b<br>    <br>    lr = Range("Q" & Rows.Count).End(xlUp).Row<br>    a = Range("Q2:Q" & lr).Value<br>    <SPAN style="color:#00007F">ReDim</SPAN> b(1 <SPAN style="color:#00007F">To</SPAN> lr - 1, 1 <SPAN style="color:#00007F">To</SPAN> 1)<br>    <SPAN style="color:#00007F">With</SPAN> CreateObject("Scripting.Dictionary")<br>        <SPAN style="color:#00007F">For</SPAN> i = 1 <SPAN style="color:#00007F">To</SPAN> lr - 1<br>            <SPAN style="color:#00007F">If</SPAN> <SPAN style="color:#00007F">Not</SPAN> .exists(a(i, 1)) <SPAN style="color:#00007F">Then</SPAN><br>                .Add a(i, 1), <SPAN style="color:#00007F">Nothing</SPAN><br>            <SPAN style="color:#00007F">Else</SPAN><br>                x = x + 1<br>                b(i, 1) = 1<br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>        <SPAN style="color:#00007F">Next</SPAN><br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>    <SPAN style="color:#00007F">If</SPAN> x > 0 <SPAN style="color:#00007F">Then</SPAN><br>        Range("AI2:AI" & lr).Value = b<br>        <SPAN style="color:#00007F">With</SPAN> Range("A2:AI" & lr)<br>            .Sort Key1:=Range("AI2"), Order1:=xlAscending, Header:=xlNo, _<br>                OrderCustom:=1, MatchCase:=False, _<br>                Orientation:=xlTopToBottom, DataOption1:=xlSortNormal<br>            .Resize(x).EntireRow.Delete<br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <SPAN style="color:#00007F">With</SPAN> Application<br>        .EnableEvents = <SPAN style="color:#00007F">True</SPAN><br>        .ScreenUpdating = <SPAN style="color:#00007F">True</SPAN><br>        .Calculation = PrevCalc<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>

 

[Biz]

Pity, for 2007+ I think all you need is this. My assumption is you have a header row.


Sub RemoveDuplicates2007()
Dim lr As Long

lr = Range("Q" & Rows.Count).End(xlUp).Row
Range("A1:AH" & lr).RemoveDuplicates Columns:=17, Header:=xlYes
End Sub



To include earlier versions, and using your code as a basis, try this (in a copy of your workbook).


Sub RemoveALLDuplicates()
With Application
.EnableEvents = False
.ScreenUpdating = False
PrevCalc = .Calculation
.Calculation = xlCalculationManual
End With
Dim r As Range, txt As String
Dim lr As Long, i As Long, x As Long
Dim a, b

lr = Range("Q" & Rows.Count).End(xlUp).Row
a = Range("Q2:Q" & lr).Value
ReDim b(1 To lr - 1, 1 To 1)
With CreateObject("Scripting.Dictionary")
For i = 1 To lr - 1
If Not .exists(a(i, 1)) Then
.Add a(i, 1), Nothing
Else
x = x + 1
b(i, 1) = 1
End If
Next
End With
If x > 0 Then
Range("AI2:AI" & lr).Value = b
With Range("A2:AI" & lr)
.Sort Key1:=Range("AI2"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
.Resize(x).EntireRow.Delete
End With
End If
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = PrevCalc
End With
End Sub

Hi Peter,

Very classy RemoveALLDuplicates.
Need to learn how to code your professional Excel VBA Gurus.

Biz