Optimizing VBA / Excel Macro Code (Finding Duplicates in Large Sheet)

Question

I haven't really ever coded in VBA or anything of the sort except short little things in VB done years ago. This is my attempt at writing some code that will search through a excel sheet database of client accounts and search for possible duplicate accounts. Sadly, on the machine that I need to run this on, it can only handle about 3,500 entries without crashing Excel. I contribute this to both my code being horribly unoptimized as-well as the machine being slow.

What can be done to optimize the following code, and what best practices in VBA should I use in the future?

'Essentially, this loops through each row in the sheet
'For each row, it loops through every row after it, searching for duplicates of itself (skipping over a rows that have previously been marked as duplicates)
'Duplicates are defined by entries that meet a 'threshhold' of similarity
'The threshhold is defined as the number '5', first and last names are each two points, address and email address are one point
'That means that in order for an entry to meet the thresshold, the first and last name must be the same, and it must also have either the same address or email
'When duplicates are found, the duplicate column is marked as 'Yes' for that row, and the first occurence column is marked with a number defining the row number where the account first appeared

Sub Main():
    Dim lNameCol, fNameCol, addressCol, emailCol, duplicateCol, fOccurenceCol As String

    'Defines the column letters for the various data fields
    lNameCol = "A"
    fNameCol = "B"
    addressCol = "C"
    emailCol = "D" 
    duplicateCol = "E"   'The column where a entry/row will be marked as being a duplicate
    fOccurenceCol = "F"  'The column that contains the row number where a duplicate accounts first occurence was found

    Call Duplicates(lNameCol, fNameCol, addressCol, emailCol, duplicateCol, fOccurenceCol)
End Sub

'Gets number of rows in currently active sheet
Function RowCount():
    Application.ActiveSheet.UsedRange
    RowCount = Worksheets("Sheet1").UsedRange.Rows.Count
End Function

'Finds and labels duplicates
Sub Duplicates(ByVal lNameCol As String, ByVal fNameCol As String, ByVal addressCol As String, ByVal emailCol As String, ByVal duplicateCol As String, ByVal fOccurenceCol As String)
    Dim lRowCount As Integer
    lRowCount = RowCount()

    'Loops through each row in the sheet
    For i = 1 To lRowCount

        Dim duplicate, lastName, firstName, email, address As String

        'Sets these variables' values corresponding cell value in row 'i'
        'UCase capitilizes things to make entries case-insensitive
        duplicate = UCase(Range(duplicateCol & i).Value)
        lastName = UCase(Range(lNameCol & i).Value)
        firstName = UCase(Range(fNameCol & i).Value)
        email = UCase(Range(emailCol & i).Value)
        address = UCase(Range(addressCol & i).Value)

        'Checks to make sure row has not already been marked a duplicate, if it hasn't it continues
        If (StrComp(duplicate = "YES", vbTextCompare) = 1) Then

            'Loops through every row after the current row (row 'i')
            For n = (i + 1) To lRowCount

                'duplicateThreshold is an integer that defines the threshhold of similarity that rows need to have in order to be labeled a duplicate
                Dim duplicateThreshhold As Integer
                Dim lastName2, firstName2, email2, address2 As String

                duplicateThreshhold = 0

                'These are the entry variables for account entry at row 'n' being compared to the account entry at row 'i'
                lastName2 = UCase(Range(lNameCol & n).Value)
                firstName2 = UCase(Range(fNameCol & n).Value)
                email2 = UCase(Range(emailCol & n).Value)
                address2 = UCase(Range(addressCol & n).Value)

                'Adds 2 points to threshhold if first name is the same
                If lastName = lastName2 Then
                    duplicateThreshhold = duplicateThreshhold + 2

                End If

                'Adds 2 points to threshold if last name is the same
                If firstName = firstName2 Then
                    duplicateThreshhold = duplicateThreshhold + 2
                End If

                'The remaining two fields give 1 point each to the thresshold
                'As long as the sum of the points given by first and last name is always greater than half of the threshhold, first and last name will always be required

                If email = email2 Or address = address2 Then
                    duplicateThreshhold = duplicateThreshhold + 1
                End If

                If duplicateThreshhold > 4 Then
                   'Labels duplicate entries as duplicates
                    Range(duplicateCol & i).Value = "Yes"
                    Range(duplicateCol & n).Value = "Yes" 

                   'Labels duplicate entries with the first occurence of that entry
                    Range(fOccurenceCol & i).Value = i 'Labels first occurence account's row number
                    Range(fOccurenceCol & n).Value = i

                End If

            Next
        End If
    Next


End Sub

Why not use the Remove Duplicates function within Excel, and not use VBA? In Excel 2013: Highlight your column, navigate to *Data->Remove Duplicates* — TheGuyThatDoesn'tKnowMuch, Mar 09 '16 at 13:35
I've found the tips on [this site](https://blogs.office.com/2009/03/12/excel-vba-performance-coding-best-practices/) good for getting my code to run faster, a good first step may be having a look there. — eirikdaude, Mar 09 '16 at 13:39
OK, it sounds like you are trying to build your own flavor of 'fuzzy logic' (something that MS has already accomplished fairly well). Take a look at [Set Auto Filtering multiple wildcards](http://stackoverflow.com/questions/16602872/), [Can Advanced Filter criteria be in the VBA rather than a range?](http://stackoverflow.com/questions/34532282/) and [Can AutoFilter take both inclusive and non-inclusive wildcards from Dictionary keys?](http://stackoverflow.com/questions/34614417). — , Mar 09 '16 at 13:42
I don't want to remove duplicates, I want to flag possible duplicates (things that have the same first and last name, and either the same email or address) for later inspection. I am also writing this for people who are very tech illiterate and just want to be able to hit 'run' and have it do what it was supposed to do. Furthermore I will be implementing some additional functionality that I can't get from advanced filtering in the future, so I'm going to continue using a custom macro. @eirikdaude, I will look at that, thanks. — RJGordon, Mar 09 '16 at 14:01
I would say you need to read your data into an array and then do processing for duplicates on the array. You could even read the duplicate "Yes"'s into the array in a new column and then output the whole thing. the slowest part of working with spreadsheets is normally accessing the sheet itself so with the above mentioned method you will only access the sheet twice, once to read once to write. — 99moorem, Mar 09 '16 at 14:07
The usual way to get rid of two nested search loops (which is quadratic in the size of the ranges) is to make them sequential rather than nested by using a `Dictionary` which is loaded in the first loop and then used to check for matches in the second loop. If the ranges are large this sort of thing can make the difference between an algorithm which takes hours to run vs. an algorithm which takes seconds to run. — John Coleman, Mar 09 '16 at 14:28
don't use `dim` inside a loop. And the way you declare multiple dim's is wrong, only the last one will be declared correctly... — Patrick Lepelletier, Mar 10 '16 at 08:13
use `option explicit`: it seems you didn't declare i, n, ... — Patrick Lepelletier, Mar 10 '16 at 08:14

score 2 · Accepted Answer · answered Mar 09 '16 at 22:39

Okay, so this is one of those problems that stuck in the back of my head, so I had to solve it (thanks a lot @RJGordon!). I ended up solving it two different ways - the first with nested loops and the second with hashed dictionaries. The second is a cleaner and faster algorithm, but I'll present both for thoroughness sake.

Nested Loops

As @JohnColeman pointed out, this method makes sense logically but scales terribly. It was easy enough to provide a list of all the duplicate rows for each record and has the advantage of tagging the first rows in the dataset. (The second solution below does not tag the initial record with the duplicates below, but you can solve for that as well if needed.)

Option Explicit

Sub test()
    MarkDuplicates ActiveSheet, 1, 2, 3, 4, 5, 6
End Sub

Sub MarkDuplicates(sh As Worksheet, lNameCol As Long, _
                   fNameCol As Long, addressCol As Long, _
                   emailCol As Long, duplicateCol As Long, _
                   fOccuranceCol As Long)
    Dim lastRow As Long
    Dim lastCol As Long
    Dim acctRange As Range
    Dim acctData As Variant
    Dim checkRow As Long
    Dim otherRow As Long
    Dim dupScore As Integer
    Dim dupList As String

    '--- determine the range of data and copy to a memory-based array
    lastRow = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
    lastCol = sh.Cells(1, sh.Columns.Count).End(xlToLeft).Column
    Set acctRange = sh.Range("A1").Resize(lastRow, lastCol)
    acctData = acctRange

    '--- nested loop to check each row against every other row
    For checkRow = 2 To lastRow
        dupList = ""
        For otherRow = 2 To lastRow
            dupScore = 0
            If otherRow <> checkRow Then
                If acctData(checkRow, lNameCol) = acctData(otherRow, lNameCol) Then
                    dupScore = dupScore + 2
                End If
                If acctData(checkRow, fNameCol) = acctData(otherRow, fNameCol) Then
                    dupScore = dupScore + 2
                End If
                If acctData(checkRow, addressCol) = acctData(otherRow, addressCol) Then
                    dupScore = dupScore + 1
                End If
                If acctData(checkRow, emailCol) = acctData(otherRow, emailCol) Then
                    dupScore = dupScore + 1
                End If
                If dupScore > 4 Then
                    dupList = dupList & otherRow & ","
                End If
            End If
        Next otherRow
        If Len(dupList) > 0 Then
            dupList = Left(dupList, Len(dupList) - 1)
            acctData(checkRow, duplicateCol) = "Yes"
            acctData(checkRow, fOccuranceCol) = dupList
        Else
            acctData(checkRow, duplicateCol) = ""
            acctData(checkRow, fOccuranceCol) = ""
        End If
    Next checkRow

    '--- copy the array back to the worksheet
    acctRange = acctData

    Set sh = Nothing
End Sub

Using Dictionaries

And I do mean dictionaries (plural). Because your duplicate score threshold can be reached with three different combinations of fields, your dictionary hash must test each combination. The dictionary key (hash) I've chosen is a concatenated string of the fields that, when tested, would indicate a duplicate record. This solution shows only a single loop with three dictionaries. If you wanted a list of all duplicate records found, then rewrite the code to create all three dictionaries in a single loop, then use a separate (not nested) loop to each record against each dictionary key and keep a running list of the dupes. (I kept it to a single loop for efficiency.)

Creating a single dictionary with a longer key (e.g. lastName+firstName+address+email) will cause you to have key collisions for records with duplicate ALL those fields, but you'll still have to find a way to test the other combinations. Someone far smarter than me may come up with a simpler way.

Option Explicit

Sub test()
    MarkDuplicates ActiveSheet, 1, 2, 3, 4, 5, 6
End Sub

Sub MarkDuplicates(sh As Worksheet, lNameCol As Long, _
                   fNameCol As Long, addressCol As Long, _
                   emailCol As Long, duplicateCol As Long, _
                   fOccuranceCol As Long)
    Dim lastRow As Long
    Dim lastCol As Long
    Dim acctRange As Range
    Dim acctData As Variant
    Dim acctDict1 As Dictionary
    Dim acctDict2 As Dictionary
    Dim acctDict3 As Dictionary
    Dim acctKey As String
    Dim checkRow As Long
    Dim otherRow As Long
    Dim dupScore As Integer
    Dim dupList As String

    '--- determine the range of data and copy to a memory-based array
    lastRow = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
    lastCol = sh.Cells(1, sh.Columns.Count).End(xlToLeft).Column
    Set acctRange = sh.Range("A1").Resize(lastRow, lastCol)
    acctData = acctRange

    Set acctDict1 = New Dictionary
    Set acctDict2 = New Dictionary
    Set acctDict3 = New Dictionary

    '--- build the initial dictionary
    '    for the key to trip as duplicate, there are three possible
    '    combinations to check, so we make three dictionaries and
    '    create keys as combinations of the fields
    For checkRow = 2 To lastRow
        '--- clear previous flags
        acctData(checkRow, duplicateCol) = ""
        acctData(checkRow, fOccuranceCol) = ""

        '--- dupe is lastname + firstname
        acctKey = acctData(checkRow, lNameCol) & acctData(checkRow, fNameCol)
        If Not acctDict1.Exists(acctKey) Then
            acctDict1.Add acctKey, checkRow
        ElseIf acctData(checkRow, duplicateCol) <> "Yes" Then
            acctData(checkRow, duplicateCol) = "Yes1"
            acctData(checkRow, fOccuranceCol) = acctDict1.Item(acctKey)
        End If

        '--- dupe is lastname + address + email
        acctKey = acctData(checkRow, lNameCol) & acctData(checkRow, addressCol) & _
                  acctData(checkRow, emailCol)
        If Not acctDict2.Exists(acctKey) Then
            acctDict2.Add acctKey, checkRow
        ElseIf acctData(checkRow, duplicateCol) <> "Yes" Then
            acctData(checkRow, duplicateCol) = "Yes2"
            acctData(checkRow, fOccuranceCol) = acctDict2.Item(acctKey)
        End If

        '--- dupe is firstname + address + email
        acctKey = acctData(checkRow, fNameCol) & acctData(checkRow, addressCol) & _
                  acctData(checkRow, emailCol)
        If Not acctDict3.Exists(acctKey) Then
            acctDict3.Add acctKey, checkRow
        ElseIf acctData(checkRow, duplicateCol) <> "Yes" Then
            acctData(checkRow, duplicateCol) = "Yes3"
            acctData(checkRow, fOccuranceCol) = acctDict3.Item(acctKey)
        End If
    Next checkRow

    '--- copy the array back to the worksheet
    acctRange = acctData

    Set sh = Nothing
End Sub

Optimizing VBA / Excel Macro Code (Finding Duplicates in Large Sheet)

1 Answers1