View Full Version : Delete Duplicate Records based on criteria


ajetrumpet
06-21-2009, 12:38 AM
Below is some code that will loop through a recordset and delete specific records based on the criteria that you write in the code. This particular function of mine searches for duplicate email addresses, and only deletes a record if the email address is the same, and the times are less than 10 minutes apart from each other. I don't believe there is an option in the query wizard to delete duplicates with this type of specific need, so I'm posting this code here for use. The section in red is what can be changed to meet your specific needs:Function DeleteDupTimes()

Dim rs1 As Recordset, rs2 As Recordset
Dim mydate As Date, myemail As String, x As Long

DoCmd.DeleteObject acTable, "clicks"
DoCmd.DeleteObject acTable, "opens"
DoCmd.CopyObject , "clicks", acTable, "clicksOLD"
DoCmd.CopyObject , "opens", acTable, "opensOLD"

RefreshDatabaseWindow

Set rs1 = CurrentDb.OpenRecordset("opens", dbOpenDynaset)
Set rs2 = CurrentDb.OpenRecordset("clicks", dbOpenDynaset)

x = 0
rs1.MoveFirst 'MOVE TO THE FIRST RECORD

With rs1 'OPENS TABLE
Do Until .EOF
myemail = !email
mydate = !Date
.MoveNext
Do Until .EOF 'CHECK ALL RECORDS FOR THE SAME EMAIL AND
TIMES WITHIN 10 MINUTES OF THE ORIGINAL RECORD
If (!email = myemail) And _
(DateDiff("n", mydate, !Date) > -10 And _
DateDiff("n", mydate, !Date) < 10) Then
.Delete 'DELETE THE DUPLICATE RECORD IF THE TWO
TIMES ARE LESS THAN 10 MINUTES APART
End If
.MoveNext
Loop
.MoveFirst
x = x + 1
.Move x 'MOVE TO THE NEXT RECORD IN LINE FOR CHECKING
Loop
End With

rs1.Close
Set rs = Nothing

x = 0
rs2.MoveFirst 'MOVE TO THE FIRST RECORD

With rs2 'CLICKS TABLE
Do Until .EOF
myemail = !email
mydate = !Date
.MoveNext
Do Until .EOF 'CHECK ALL RECORDS FOR THE SAME EMAIL AND
TIMES WITHIN 10 MINUTES OF THE ORIGINAL RECORD
If (!email = myemail) And _
(DateDiff("n", mydate, !Date) > -10 And _
DateDiff("n", mydate, !Date) < 10) Then
.Delete 'DELETE THE DUPLICATE RECORD IF THE TWO
TIMES ARE LESS THAN 10 MINUTES APART
End If
.MoveNext
Loop
.MoveFirst
x = x + 1
.Move x 'MOVE TO THE NEXT RECORD IN LINE FOR CHECKING
Loop
End With

rs2.Close
Set rs2 = Nothing

End Function

The attachment shows the result in this example.