Excel|2007|2003|Microsoft Excel|Formula|Function|Pivto Table|Excel Topics|Passwords|Hyperlink Excel Guru: Test for duplicates in eight columns, combined (and delete duplicates) in Excel 2003/XP/2000/97

Friday, October 2, 2009

Test for duplicates in eight columns, combined (and delete duplicates) 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?

Answer: Let's take a look at an example.
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 (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 two 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 As String
Dim LColA_2, LColB_2, LColC_2, LColD_2, LColE_2, LColF_2, LColG_2, LColH_2 As String

'Test first 2000 rows in spreadsheet for duplicates (delete any duplicates found)
Lrows = 2000
LLoop = 2
LCnt = 0

'Check first 2000 rows in spreadsheet
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)

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)

'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

'Delete the duplicate
Rows(CStr(LTestLoop) & ":" & CStr(LTestLoop)).Select
Selection.Delete Shift:=xlUp

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

LCnt = LCnt + 1

End If

End If

LTestLoop = LTestLoop + 1
Wend

End If

LLoop = LLoop + 1
Wend

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

End Sub

0 comments:

Post a Comment