Optimizing VBA / Excel Macro Code (Finding Duplicates in Large Sheet)
<p>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. </p>

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

<pre><code>'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 &amp; i).Value)
        lastName = UCase(Range(lNameCol &amp; i).Value)
        firstName = UCase(Range(fNameCol &amp; i).Value)
        email = UCase(Range(emailCol &amp; i).Value)
        address = UCase(Range(addressCol &amp; 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 &amp; n).Value)
                firstName2 = UCase(Range(fNameCol &amp; n).Value)
                email2 = UCase(Range(emailCol &amp; n).Value)
                address2 = UCase(Range(addressCol &amp; 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 &gt; 4 Then
                   'Labels duplicate entries as duplicates
                    Range(duplicateCol &amp; i).Value = "Yes"
                    Range(duplicateCol &amp; n).Value = "Yes" 

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

                End If

            Next
        End If
    Next


End Sub
</code></pre>