Find duplicate rows where value of cell with time criteria is within 30 mins

[emm8080]

Hi

I have several rows of data eg

A B C D
1 Date Time ID GateNo
2 30/10/2013 09:24 1224 2
3 30/10/2013 23:34 1224 3
4 29/10/2013 09:45 2456 2
5 30/10/2013 23:10 1224 3
6 31/10/2013 00:01 1224 3

I want to find rows where the values in columns C and D are identical AND where the Date/Time (columns A and B) are within 30 minutes. So in the example, this would be rows 3, 5 and 6 where the ID and GateNo are the same and the times are within 30 minutes of each other (note, rows 3 and 6 are within 30 mins but on different dates).

Thanks.

[MickG]

Try this:-
This code will show results in column "E" on.

Sub MG31Oct28
Dim Rng As Range, Dn As Range
Dim ColCD As String
Dim Dic As Object
Dim c As Long
Dim nRng As Range
Dim TempRng As Range
Dim Ray As Variant
Set Rng = Range(Range("C2"), Range("C" & Rows.Count).End(xlUp))
Ray = Rng.Offset(, -1)
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For Each Dn In Rng
    ColCD = Dn & Dn.Offset(, 1)
        If Not Dic.Exists(ColCD) Then
            Dic.Add ColCD, Dn.Offset(, -1)
        Else
            Set Dic.Item(ColCD) = Union(Dic.Item(ColCD), Dn.Offset(, -1))
        End If
Next

Dim k
Dim G As Range
Dim Rw As Range
 For Each k In Dic.keys
    For Each G In Dic(k)
        Set nRng = G
        For Each Rw In Dic(k)
            If Not Rw.Address = G.Address And Rw.Row > G.Row Then
                If Rw > "" And G > "" Then
                    If Abs(DateDiff("n", Rw.Offset(, -1) + Rw, G.Offset(, -1) + G)) <= 30 Then
                        Set nRng = Union(nRng, Rw)
                    End If
                End If
            End If
        Next Rw
    If nRng.Count > 1 Then
        c = c + 1
        nRng.Offset(, 2 + c) = "Dup" & c
        nRng = ""
    End If
    Set nRng = Nothing
    Next G
 Next k
Range("B2").Resize(UBound(Ray, 1)) = Ray
End Sub

Regards Mick

[emm8080]

Hi Mick

That's great! One thing: With example below Person4 on the 8th row is within 30 mins of Person4 on the 7th row, but not showing as Dupe - I guess because it's not within 30mins of the first Dup2 time? So rows 6, 7 and 8 should all be Dupes as shown by (Dup4). Appreciate this adds an extra layer of complexity! Thanks for your help! Emma

Date Time ID GateNo
23/09/2013 20:33 Person1 A45
23/09/2013 20:33 Person2 A45 Dup1
23/09/2013 20:33 Person3 A45
23/09/2013 20:33 Person4 A45 Dup2
23/09/2013 20:43 Person2 A45 Dup1
23/09/2013 20:23 Person4 A45 Dup2 (Dup4)
23/09/2013 20:13 Person4 A45 Dup2 (Dup4)
23/09/2013 20:02 Person4 A45 (Dup4)
23/09/2013 23:55 Person3 A22 Dup3
24/09/2013 00:15 Person3 A22 Dup3
23/09/2013 19:40 Person4 A45 (Dup4)

[MickG]

Try this:- This is better code.
The results need some interpretation, because for each set of unique "ID GateNo", the code looks at each time within the related set of times to find any others times that are within 30 min of the first time. Then it does the same for each susequent time in the set of related times.
As a Consequence you get these half related sets of dups.

Sub MG01Nov35
Dim Rng     As Range
Dim Dn      As Range
Dim ColCD   As String
Dim Dic     As Object
Dim c       As Long
Dim nRng    As Range
Dim TempRng As Range
Dim ray     As Variant

Set Rng = Range(Range("C2"), Range("C" & Rows.Count).End(xlUp))
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For Each Dn In Rng
    ColCD = Dn & Dn.Offset(, 1)
        If Not Dic.Exists(ColCD) Then
            Dic.Add ColCD, Dn.Offset(, -1)
        Else
            Set Dic.Item(ColCD) = Union(Dic.Item(ColCD), Dn.Offset(, -1))
        End If
Next

Dim k As Variant
Dim G As Range
Dim Rw As Range
Dim n As Long
Dim oLp As Long
Dim iLp As Long
 For Each k In Dic.keys
    n = 0
    ReDim ray(1 To Dic(k).Count) As Range
        For Each G In Dic.Item(k)
            n = n + 1
            Set ray(n) = G
        Next G

For oLp = 1 To UBound(ray)
   Set nRng = ray(oLp)
    For iLp = oLp To UBound(ray)
        If Not ray(iLp).Address = ray(oLp).Address Then
        If Abs(DateDiff("n", ray(iLp).Offset(, -1) + ray(iLp), ray(oLp).Offset(, -1) + ray(oLp))) <= 30 Then
            Set nRng = Union(nRng, ray(iLp))
        End If
        End If
Next iLp
 
    If nRng.Count > 1 Then
        c = c + 1
        nRng.Offset(, 2 + c) = "Dup" & c
    End If
    Set nRng = Nothing
Next oLp
Next k
End Sub

Regards Mick

[emm8080]

Sorry for late response...thank you so much for your help, I'm sure I can work with this!
Kind regards Emma

[MickG]

Thanks for your reply:-
The code below should give better results, as it checks each Unique person against each duplicate of that unique person and returns the results starting column "E" .
NB:- Your actual data is expected to start on row (2) , as per your thread data.

Sub MG06Nov30
Dim Rng         As Range
Dim Dn          As Range
Dim n           As Long
Dim Q
Dim oMax        As Long
Dim oCol    As Long
Dim iCol    As Long
Dim Rw      As Long

Dim ac      As Long
Dim Fd As Boolean
Set Rng = Range(Range("C2"), Range("C" & Rows.Count).End(xlUp))
    ReDim nR(1 To Rng.Count, 1 To Rng.Count)
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
For Each Dn In Rng
    If Not .Exists(Dn.Value & "," & Dn.Offset(, 1).Value) Then
        n = n + 1
        Set nR(n, 1) = Dn
        .Add Dn.Value & "," & Dn.Offset(, 1).Value, Array(nR, n, 1)
    Else
        Q = .Item(Dn.Value & "," & Dn.Offset(, 1).Value)
            Q(2) = Q(2) + 1
            Set nR(Q(1), Q(2)) = Dn
            oMax = Application.Max(oMax, Q(2))
         .Item(Dn.Value & "," & Dn.Offset(, 1).Value) = Q
    End If
Next
End With
ReDim Preserve nR(1 To Rng.Count, 1 To oMax)
   
   For Rw = 1 To UBound(nR, 1)
        
        For oCol = 1 To UBound(nR, 2)
            If Not IsEmpty(nR(Rw, oCol)) Then
                For iCol = oCol + 1 To UBound(nR, 2)
                    If Not IsEmpty(nR(Rw, iCol)) Then
                        If Abs(DateDiff("n", nR(Rw, oCol).Offset(, -2) + nR(Rw, oCol).Offset(, -1), nR(Rw, iCol).Offset(, -2) + nR(Rw, iCol).Offset(, -1))) <= 30 Then
                            Fd = True
                         End If
                        
                    If Fd = True Then
                        ac = ac + 1
                        nR(Rw, oCol).Offset(, 1 + ac).EntireColumn.ClearContents
                        Cells(1, ac + 4) = nR(Rw, oCol)
                        nR(Rw, oCol).Offset(, 1 + ac) = "Dup " & ac
                        nR(Rw, iCol).Offset(, 1 + ac) = "Dup " & ac
                        Fd = False
                    End If

                End If
            Next iCol
        End If
    Next oCol
Next Rw
End Sub

Regards Mick