Optimizing VBA / Excel Macro Code (Finding Duplicates and Sorting Large Data Set )

Question

I currently have a code written to find duplicate values starting in range "A3" to last row used; highlight duplicates red, both the first and last instance; Filter by color highlighted and finally sort smallest to largest.

I will be using these duplicates later to copy to another sheet. The data starts in column "A3" to "V3" and to last row used. Data will range anywhere from 10,000 to 40,000 rows, maybe more depending on the data received.

My problem is this marco runs very slow and at times will freeze up.. Is there another way to achieve the same result but more efficiently and quicker?

Sub filtersort ()

Dim sht As Worksheet
Set sht = Worksheets("Sheet1")

Lastrow = Range("A" & Rows.Count).End(xlUp).Row
N = Cells(Rows.Count, "A").End(xlUp).Row

sht.Range("A3:A" & Lastrow).Select

Selection.FormatConditions.AddUniqueValues

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
With Selection.FormatConditions(1).Font
    .Color = -16383844
    .TintAndShade = 0
End With

With Selection.FormatConditions(1).Interior
    .PatternColorIndex = xlAutomatic
    .Color = 13551615
    .TintAndShade = 0

End With

Selection.FormatConditions(1).StopIfTrue = False
sht.Range("A3:A" & Lastrow).Select
Application.CutCopyMode = False
Selection.AutoFilter
ActiveSheet.Range("$A$3:$A$" & Lastrow).AutoFilter Field:=1, Criteria1:=RGB(255, _
    199, 206), Operator:=xlFilterCellColor

sht.Range("A3:V" & N).Sort Key1:=Range("A1"), Order1:=xlDescending, Header:=xlYes

End Sub

Subodh Tiwari sktneer · Accepted Answer · 2017-05-24 07:10:47Z

1

The autofilter is responsible for slow running code. The number of unique items would all affect the speed of the code.

If your intention is to retrieve the sorted duplicate data, you may try this approach.

The code given below will add a new sheet called "Duplicate Data" with all the duplicate data and sort it on column A.

The code assumes that the data is on a sheet called Sheet1, row3 being the header row and actual data starts from row4.

Modify it if required.

Sub filtersort()

Dim wsData As Worksheet, wsOutput As Worksheet
Dim Rng As Range
Dim LastRow As Long, LastCol As Long, i As Long, j As Long, n As Long
Dim arr(), x, dict, arrOut()

With Application
    .Calculation = xlCalculationManual
    .EnableEvents = False
    .ScreenUpdating = False
End With

Set wsData = Worksheets("Sheet1")

On Error Resume Next
Set wsOutput = Sheets("Duplicate Data")
wsOutput.Cells.Clear
On Error GoTo 0

If wsOutput Is Nothing Then
    Sheets.Add(after:=wsData).Name = "Duplicate Data"
    Set wsOutput = ActiveSheet
End If
LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
LastCol = wsData.Cells(3, Columns.Count).End(xlToLeft).Column + 1

Set Rng = wsData.Range("A3:A" & LastRow)

x = wsData.Range("A4:V" & LastRow).Value
Set dict = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(x, 1)
    If Not dict.exists(x(i, 1)) Then
        dict.Item(x(i, 1)) = ""
    Else
        j = j + 1
        ReDim Preserve arr(1 To j)
        arr(j) = x(i, 1)
    End If
Next i

ReDim arrOut(1 To UBound(x, 1), 1 To UBound(x, 2))
For i = 1 To UBound(x, 1)
    If Not IsError(Application.Match(x(i, 1), arr, 0)) Then
        n = n + 1
        For j = 1 To UBound(x, 2)
            arrOut(n, j) = x(i, j)
        Next j
    End If
Next i

wsData.Range("A3:V3").Copy wsOutput.Range("A3")

wsOutput.Range("A4").Resize(n, UBound(x, 2)).Value = arrOut

LastRow = wsOutput.Cells(Rows.Count, 1).End(xlUp).Row

wsOutput.Range("A3:V" & LastRow).Sort Key1:=wsOutput.Range("A4"), Order1:=xlDescending, Header:=xlYes
With Application
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
    .ScreenUpdating = True
End With
End Sub

answered May 24, 2017 at 7:10

Subodh Tiwari sktneer

9,9862 gold badges20 silver badges22 bronze badges

Sign up to request clarification or add additional context in comments.

7 Comments

Tom Over a year ago

WOW! That was a great improvement thank you very much. The only issue im having is keeping the number formats and values the same when transfering duplicate data from "sheet1" to "Duplicate Data".

Tom Over a year ago

Also, after these duplicates are transfered; is there an efficient way to delete just the duplicates from sheet one? I would be doing this in another macro.

Subodh Tiwari sktneer Over a year ago

You can have a separate code to copy the format of the columns to the output sheet and call it once code writes the data into it.

Subodh Tiwari sktneer Over a year ago

You can open a new question with your next requirement. :)

Tom Over a year ago

quick follow up question on the code you have provided; When the data set used contains duplicates it runs flawlessly, although when a data set is entered with no duplicates I recieve an error and the code does not run.. Any Ideas on how I can fix this?

|

Chris Harper · Accepted Answer · 2017-05-24 04:09:04Z

1

You can use Pivot Table to bring Count of the items and just remove filter from blank and 1 count items and here is your duplicate values list. You can automate this process with using VBA.

answered May 24, 2017 at 4:09

Chris Harper

2132 silver badges10 bronze badges

Comments

ClintB · Accepted Answer · 2017-05-24 05:21:36Z

0

Write a formula in the last column of the sheet that would return the RowNumber for the record. Meaning the first time a record is found it returns 1. The second time it returns 2, third time 3, etc.

Once you have this formula correct you can automate this part in vba.

Now sort your data by this column.

Cut and paste in bulk where rowNumber>1. So many times I see similar things where people process it line by line in vba. It is a lot slower then using formula in the workbook. Sorting and cutting.

answered May 24, 2017 at 5:21

ClintB

4893 silver badges6 bronze badges

Collectives™ on Stack Overflow

Optimizing VBA / Excel Macro Code (Finding Duplicates and Sorting Large Data Set )

3 Answers 3

7 Comments

Comments

Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

3 Answers 3

7 Comments

Comments

Comments

Your Answer

Sign up or log in

Post as a guest

Related