Reputation: 47
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
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
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
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