CODEWITHSUNDEEP
excelvbaperformance
Stese
Stese

Reputation: 285

Can I make this macro/code faster? (Excel VBA Duplication finder)

I'm using the following code to highlight two columns with duplicate entries. 

Sub ChkDup()
'Declare All Variables
Dim myCell As Range
Dim matRow As Integer
Dim batRow As Integer
Dim matRange As Range
Dim batRange As Range
Dim m As Integer
Dim b As Integer

'set rows as we know them
matRow = 1000
batRow = 1000

'Loop each column to check duplicate values & highlight them.
For m = 3 To matRow
Set matRange = Range("A3:A1000")

'Loop, and highlight all matching materials
For Each myCell In matRange
If WorksheetFunction.CountIf(matRange, myCell.Value) > 1 Then
myCell.Interior.ColorIndex = 3
End If
Next
Next

'Loop again for batches
For b = 3 To batRow
Set batRange = Range("B3:B1000")
For Each myCell In batRange
If WorksheetFunction.CountIf(batRange, myCell.Value) > 1 Then
myCell.Interior.ColorIndex = 6
End If
Next
Next

End Sub

The two columns have 'separate' duplicates as it's only when the mat AND the bat values match that i'm looking for. I could look for this specific condition programmatically, but my VBA is poor to say the least.

The area has 1000 rows, and it should be checking one column at at time. The macro takes around 40 seconds to highlight each column. Is this an expected time? Could I make it faster without making it too complicated? I could need to expand the search to 10000 row.

Here is the example data.

example data

Upvotes: 0

Views: 85

Answers (1)

shrivallabha.redij
shrivallabha.redij

Reputation: 5902

You have unnecessary loop sitting on top of each duplicate checking loop. It is bound to slow down your code.

I have edited your code. It should run faster and give same results!

Sub ChkDupRevised()
    'Declare All Variables
    Dim myCell As Range
    Dim chkRow As Long
    Dim chkRange As Range

    'set rows as we know them
    chkRow = 1000

    'check column A
    Set chkRange = Range("A3:A" & chkRow)
    For Each myCell In chkRange
        If WorksheetFunction.CountIf(chkRange, myCell.Value) > 1 Then
            myCell.Interior.ColorIndex = 3
        End If
    Next

    'check column B
    Set chkRange = Range("B3:B" & chkRow)
    For Each myCell In chkRange
        If WorksheetFunction.CountIf(chkRange, myCell.Value) > 1 Then
            myCell.Interior.ColorIndex = 6
        End If
    Next

End Sub

Upvotes: 1

Related Questions