patternMinor
Find Duplicate with 2 criteria
Viewed 0 times
withduplicatecriteriafind
Problem
My code below find the duplicates based on 2 criteria:
What I am looking is to increase the speed of this code, because I am working with more than 150K rows and it takes hours.
```
Sub MDMDuplicates()
Dim WB As Workbook
Dim wsRawData As Worksheet, wsConso As Worksheet
Dim i As Long, j As Long, Lastrow As Long, LastrowConso as Long
Dim SupNameToCheck As String, ConsoSupplierDUNS As String, ConsoSupplierMDM As String, ConsoSupplierNAME As String
Set WB = ThisWorkbook
Set wsRawData = WB.Sheets("RawData")
Set wsConso = WB.Sheets("Conso")
Lastrow = wsRawData.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
With wsRawData
For i = 2 To Lastrow
SupNameToCheck = .Cells(i, "A").Value
SupCountryToCheck = .Cells(i, "D")
ConsoSupplierDUNS = ""
ConsoSupplierMDM = ""
ConsoSupplierNAME = ""
j = Lastrow
Do
If i <> j And SupNameToCheck = .Cells(j, "A") And SupCountryToCheck = .Cells(j, "D") Then
If ConsoSupplierNAME = "" Then
ConsoSupplierDUNS = .Cells(i, "B") & "," & .Cells(j, "B")
ConsoSupplierMDM = .Cells(i, "C") & "," & .Cells(j, "C")
ConsoSupplierNAME = SupNameToCheck & "," & .Cells(j, "A")
Else
ConsoSupplierDUNS = .Cells(j, "B") & "," & ConsoSupplierDUNS
ConsoSupplierMDM = .Cells(j, "C") & "," & ConsoSupplierMDM
ConsoSupplierNAME = .Cells(j, "A") & "," & ConsoSupplierNAME
End If
.Cells(j, "A").EntireRow.Delete
End If
j = j - 1
Loop Until j = 1
LastrowConso = wsConso.Range("A" & Rows.Count).End(xlUp).Row + 1
If Not ConsoSupplierNAME = "" Then
wsConso.Cells(LastrowConso, "B") = ConsoSupplierDUNS
wsConso.Cells(LastrowConso, "C") = ConsoSupplierMDM
wsConso.Cells(LastrowConso, "A") = ConsoSupplierNAME
Else
- The first criteria is the Name in
Column A
- The second criteria is the Country in
Column D
Sheet("RawData") :Sheets("Conso") after the macro:What I am looking is to increase the speed of this code, because I am working with more than 150K rows and it takes hours.
```
Sub MDMDuplicates()
Dim WB As Workbook
Dim wsRawData As Worksheet, wsConso As Worksheet
Dim i As Long, j As Long, Lastrow As Long, LastrowConso as Long
Dim SupNameToCheck As String, ConsoSupplierDUNS As String, ConsoSupplierMDM As String, ConsoSupplierNAME As String
Set WB = ThisWorkbook
Set wsRawData = WB.Sheets("RawData")
Set wsConso = WB.Sheets("Conso")
Lastrow = wsRawData.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
With wsRawData
For i = 2 To Lastrow
SupNameToCheck = .Cells(i, "A").Value
SupCountryToCheck = .Cells(i, "D")
ConsoSupplierDUNS = ""
ConsoSupplierMDM = ""
ConsoSupplierNAME = ""
j = Lastrow
Do
If i <> j And SupNameToCheck = .Cells(j, "A") And SupCountryToCheck = .Cells(j, "D") Then
If ConsoSupplierNAME = "" Then
ConsoSupplierDUNS = .Cells(i, "B") & "," & .Cells(j, "B")
ConsoSupplierMDM = .Cells(i, "C") & "," & .Cells(j, "C")
ConsoSupplierNAME = SupNameToCheck & "," & .Cells(j, "A")
Else
ConsoSupplierDUNS = .Cells(j, "B") & "," & ConsoSupplierDUNS
ConsoSupplierMDM = .Cells(j, "C") & "," & ConsoSupplierMDM
ConsoSupplierNAME = .Cells(j, "A") & "," & ConsoSupplierNAME
End If
.Cells(j, "A").EntireRow.Delete
End If
j = j - 1
Loop Until j = 1
LastrowConso = wsConso.Range("A" & Rows.Count).End(xlUp).Row + 1
If Not ConsoSupplierNAME = "" Then
wsConso.Cells(LastrowConso, "B") = ConsoSupplierDUNS
wsConso.Cells(LastrowConso, "C") = ConsoSupplierMDM
wsConso.Cells(LastrowConso, "A") = ConsoSupplierNAME
Else
Solution
The first thing to do before making any changes to this code, is to improve its readability. I saw
The keyword here, is indentation.
When the
Proper indentation cannot be underestimated.
You have redundant object references:
"CodeName" is a property of all sheet objects in Excel VBA; there's a global object reference pointing to these, readily available for you to use - no need to fetch it from
Whenever you set that value to
Don't assume things won't blow up. They always do.
Now that's great, but you're deleting rows, which should trigger a recalculation if calculation is set to
.Cells and thought "oh we're in a With block" ...and then had to look three times to find the With statement.The keyword here, is indentation.
Sub DoSomething()
....
....With SomeObject
....|...
....|...If SomeCondition Then
....|...|...DoActionOne
....|...Else
....|...|...DoActionTwo
....|...End If
....|...
....|...Do
....|...|...DoActionThree
....|...Loop
....|...
....End With
....
....For i = 1 To 10
....|....
....|....DoActionFour
....|....
....Next
....
End SubWhen the
Else blocks don't line up with the corresponding If statement, or when a Loop keyword doesn't line up with its corresponding Do keyword, or when nested blocks line up in column 1, you basically set yourself up for making a change that introduces a bug.Proper indentation cannot be underestimated.
You have redundant object references:
- If
WB.Sheets("RawData")has CodeNameSheet1, name itRawDataSheetand use that reference instead.
- If
WB.Sheets("Conso")has CodeNameSheet2, name itConsoSheetand use that reference instead.
"CodeName" is a property of all sheet objects in Excel VBA; there's a global object reference pointing to these, readily available for you to use - no need to fetch it from
WB.Sheets collection, which by the way could give you non-worksheet objects, since the Sheets collection includes Charts, among other sheet types. You probably meant to use the WB.Worksheets collection instead. But then again, you don't need it - just use the global object VBA gives you for free instead.Application.ScreenUpdating = FalseWhenever you set that value to
False, you need to handle runtime errors and make sure that whatever happens, the method can't exit without setting it back to True. Otherwise Excel will look "frozen" when it's actually completely responsive, just not redrawing itself... because you told it not to.Don't assume things won't blow up. They always do.
Sub DoSomething()
On Error GoTo CleanFail
Application.ScreenUpdating = False
'...
CleanExit:
Application.ScreenUpdating = True
Exit Sub
CleanFail:
'handle errors
Resume CleanExit
End SubNow that's great, but you're deleting rows, which should trigger a recalculation if calculation is set to
xlAutomatic. Consider not only turning off ScreenUpdating, but also setting Calculation to xlManual while you're doing your thing.Code Snippets
Sub DoSomething()
....
....With SomeObject
....|...
....|...If SomeCondition Then
....|...|...DoActionOne
....|...Else
....|...|...DoActionTwo
....|...End If
....|...
....|...Do
....|...|...DoActionThree
....|...Loop
....|...
....End With
....
....For i = 1 To 10
....|....
....|....DoActionFour
....|....
....Next
....
End SubApplication.ScreenUpdating = FalseSub DoSomething()
On Error GoTo CleanFail
Application.ScreenUpdating = False
'...
CleanExit:
Application.ScreenUpdating = True
Exit Sub
CleanFail:
'handle errors
Resume CleanExit
End SubContext
StackExchange Code Review Q#120281, answer score: 3
Revisions (0)
No revisions yet.