MS Excel: Test for duplicates in eight columns, combined (and delete duplicates and originals that were duplicated) in Excel 2003/XP/2000/97

Question: In Excel 2003/XP/2000/97, is it possible to write a macro to check 8 columns over 2000 rows and delete the duplicates as well as the original row that the duplicate was based on?

Answer: Let's take a look at an example.

Download Excel spreadsheet (as demonstrated below)

In our spreadsheet, we've set up values in columns A through H. On Sheet1, we've created a button that when clicked will launch a macro. This macro will delete any duplicate values as well as the original row that the duplicate was based on (based on the values in columns A through H).

When the macro has completed, a message box will appear that indicates how many duplicate rows were deleted.

After the macro has run, you can see that four rows have been deleted.

You can press Alt-F11 to view the VBA code.

Please note that the LRows variable in this macro is set to 2000 indicating that the macro will test the first 2000 rows in for duplicates. You may need to change this value to accommodate your volume of data.

Macro Code:

The macro code looks like this:

Sub TestForDups()

    Dim LLoop As Integer
    Dim LTestLoop As Integer

    Dim Lrows As Integer
    Dim LRange As String

    Dim LCnt As Integer

    'Column values
    Dim LColA_1, LColB_1, LColC_1, LColD_1, LColE_1, LColF_1, LColG_1, LColH_1, LColI_1 As String
    Dim LColA_2, LColB_2, LColC_2, LColD_2, LColE_2, LColF_2, LColG_2, LColH_2, LColI_2 As String

    'Test first 2000 rows in spreadsheet for duplicates (delete any duplicates found as well
    ' as the original row)
    Lrows = 2000
    LLoop = 2

    'First pass: Check first 2000 rows in spreadsheet (only flag records for deletion)
    While LLoop <= Lrows
        LColA_1 = "A" & CStr(LLoop)
        LColB_1 = "B" & CStr(LLoop)
        LColC_1 = "C" & CStr(LLoop)
        LColD_1 = "D" & CStr(LLoop)
        LColE_1 = "E" & CStr(LLoop)
        LColF_1 = "F" & CStr(LLoop)
        LColG_1 = "G" & CStr(LLoop)
        LColH_1 = "H" & CStr(LLoop)
        LColI_1 = "I" & CStr(LLoop)

        If Len(Range(LColA_1).Value) > 0 Then

            'Test each value for uniqueness
            LTestLoop = LLoop + 1
            While LTestLoop <= Lrows
                If LLoop <> LTestLoop Then
                    LColA_2 = "A" & CStr(LTestLoop)
                    LColB_2 = "B" & CStr(LTestLoop)
                    LColC_2 = "C" & CStr(LTestLoop)
                    LColD_2 = "D" & CStr(LTestLoop)
                    LColE_2 = "E" & CStr(LTestLoop)
                    LColF_2 = "F" & CStr(LTestLoop)
                    LColG_2 = "G" & CStr(LTestLoop)
                    LColH_2 = "H" & CStr(LTestLoop)
                    LColI_2 = "I" & CStr(LTestLoop)

                    'Value has been duplicated in another cell (based on values in columns A to H)
                    If (Range(LColA_1).Value = Range(LColA_2).Value) _
                     And (Range(LColB_1).Value = Range(LColB_2).Value) _
                     And (Range(LColC_1).Value = Range(LColC_2).Value) _
                     And (Range(LColD_1).Value = Range(LColD_2).Value) _
                     And (Range(LColE_1).Value = Range(LColE_2).Value) _
                     And (Range(LColF_1).Value = Range(LColF_2).Value) _
                     And (Range(LColG_1).Value = Range(LColG_2).Value) _
                     And (Range(LColH_1).Value = Range(LColH_2).Value) Then

                        'Flag the duplicate and original for deletion
                        Range(LColI_1).Value = "DELETE"
                        Range(LColI_2).Value = "DELETE"

                    End If
                End If

                LTestLoop = LTestLoop + 1
            Wend

        End If

        LLoop = LLoop + 1
    Wend

    LCnt = 0
    LLoop = 2

    'Second pass: Delete records flagged for deletion
    While LLoop <= Lrows
        If Range("I" & CStr(LLoop)) = "DELETE" Then

            'Delete row
            Rows(CStr(LLoop) & ":" & CStr(LLoop)).Select
            Selection.Delete Shift:=xlUp

            'Decrement counter since row was deleted
            LLoop = LLoop - 1

            LCnt = LCnt + 1

        End If

        LLoop = LLoop + 1
    Wend

    'Reposition back on cell A1
    Range("A1").Select
    MsgBox CStr(LCnt) & " rows have been deleted."

End Sub