Tom
Tom

Reputation: 47

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

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

Upvotes: 0

Views: 1200

Answers (3)

Subodh Tiwari sktneer
Subodh Tiwari sktneer

Reputation: 9966

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

Upvotes: 1

ClintB
ClintB

Reputation: 509

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.

Upvotes: 0

Chris Harper
Chris Harper

Reputation: 213

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.

Upvotes: 1

Related Questions