Remove Duplicate depending on date and time

Sharid · May 10, 2018

Please could someone have a look at this as its a bit too hard for me to code.

On MY workbook Have 3 sheet

Sheet1 = “Customer Records”
Sheet2 = “Data”
Sheet3 = “Dormant”

I take data from an online web form and paste it in to Sheet2 “Data”. I then run the vba to sort the data, this bit is fine.

I then import this data into Sheet1 = “Customer Record”

This is my issue. I need to check that I don’t have a duplicate ID, if so remove then previous one into Sheet 3 “Dormant”. See Example Below

	[FONT=&quot]A[/FONT]	[FONT=&quot]B[/FONT]	[FONT=&quot]C[/FONT]	[FONT=&quot]D[/FONT]	[FONT=&quot]E[/FONT]	[FONT=&quot]F[/FONT]	[FONT=&quot]G[/FONT]
[FONT=&quot]ROW 1[/FONT]	[FONT=&quot]Date Imported[/FONT]	[FONT=&quot]UserID[/FONT]	[FONT=&quot]submit_date[/FONT]	[FONT=&quot]submit_time[/FONT]	[FONT=&quot]Name[/FONT]	[FONT=&quot]Individual[/FONT]	[FONT=&quot]New Form[/FONT]
[FONT=&quot]ROW 2[/FONT]	[FONT=&quot]09/05/2018[/FONT]	[FONT=&quot]1[/FONT]	[FONT=&quot]08/05/2018[/FONT]	[FONT=&quot]13:09:52[/FONT]	[FONT=&quot]John Smith[/FONT]	[FONT=&quot]Individual[/FONT]	[FONT=&quot]New Form[/FONT]
[FONT=&quot]ROW 3[/FONT]	[FONT=&quot]09/05/2018[/FONT]	[FONT=&quot]6[/FONT]	[FONT=&quot]08/05/2018[/FONT]	[FONT=&quot]12:55:56[/FONT]	[FONT=&quot]Jane Doe[/FONT]	[FONT=&quot]Individual[/FONT]	[FONT=&quot]New Form[/FONT]
[FONT=&quot]ROW 4[/FONT]	[FONT=&quot]09/05/2018[/FONT]	[FONT=&quot]8[/FONT]	[FONT=&quot]08/05/2018[/FONT]	[FONT=&quot]12:52:48[/FONT]	[FONT=&quot]Jane Smith[/FONT]	[FONT=&quot]Individual[/FONT]	[FONT=&quot]New Form[/FONT]
[FONT=&quot]ROW 5[/FONT]	[FONT=&quot]24/05/2018[/FONT]	[FONT=&quot]4[/FONT]	[FONT=&quot]09/05/2018[/FONT]	[FONT=&quot]13:09:52[/FONT]	[FONT=&quot]Jane Doe[/FONT]	[FONT=&quot]Individual[/FONT]	[FONT=&quot]New Form[/FONT]
[FONT=&quot]ROW 6[/FONT]	[FONT=&quot]24/05/2018[/FONT]	[FONT=&quot]8[/FONT]	[FONT=&quot]20/05/2018[/FONT]	[FONT=&quot]12:55:56[/FONT]	[FONT=&quot]Jane Smith[/FONT]	[FONT=&quot]Individual[/FONT]	[FONT=&quot]New Form[/FONT]
[FONT=&quot]ROW 7[/FONT]	[FONT=&quot]24/05/2018[/FONT]	[FONT=&quot]8[/FONT]	[FONT=&quot]20/05/2018[/FONT]	[FONT=&quot]12:52:48[/FONT]	[FONT=&quot]Jane Smith[/FONT]	[FONT=&quot]Individual[/FONT]	[FONT=&quot]New Form[/FONT]

Column A = Date the data was imported from Sheet 2 “Data” by me.
Column B = User ID – Each user will have a unique ID
Column C = Date the form was submitted online
Column D = The time it was submitted online.

In the above example, Jane Smith has a USER ID of 8 she has submitted 3 of the same form 1 on the 8^th and 2 on the 20^th. I have highlighted these in red and green for your reference only.

The most recent and up to date form from JANE SMITH is the one shown in Green ROW 6, as it was submitted at 12:55:56 on the 20/5/2018. This is the data I need to keep. The other two on ROW 4 and ROW 7 need to be moved to dormant to paste into next blank row.

I was thinking that the code should run as - It check column B for ID, if MATCHED then check data and time submitted. It keeps the newest one and removes any other that match that ID

The end result should look like this in “Customer Records”

	[FONT=&quot]A[/FONT]	[FONT=&quot]B[/FONT]	[FONT=&quot]C[/FONT]	[FONT=&quot]D[/FONT]	[FONT=&quot]E[/FONT]	[FONT=&quot]F[/FONT]	[FONT=&quot]G[/FONT]
[FONT=&quot]ROW 1[/FONT]	[FONT=&quot]Date Imported[/FONT]	[FONT=&quot]UserID[/FONT]	[FONT=&quot]submit_date[/FONT]	[FONT=&quot]submit_time[/FONT]	[FONT=&quot]Name[/FONT]	[FONT=&quot]Individual[/FONT]	[FONT=&quot]New Form[/FONT]
[FONT=&quot]ROW 2[/FONT]	[FONT=&quot]09/05/2018[/FONT]	[FONT=&quot]1[/FONT]	[FONT=&quot]08/05/2018[/FONT]	[FONT=&quot]13:09:52[/FONT]	[FONT=&quot]John Smith[/FONT]	[FONT=&quot]Individual[/FONT]	[FONT=&quot]New Form[/FONT]
[FONT=&quot]ROW 3[/FONT]	[FONT=&quot]09/05/2018[/FONT]	[FONT=&quot]6[/FONT]	[FONT=&quot]08/05/2018[/FONT]	[FONT=&quot]12:55:56[/FONT]	[FONT=&quot]Jane Doe[/FONT]	[FONT=&quot]Individual[/FONT]	[FONT=&quot]New Form[/FONT]
[FONT=&quot]ROW 4[/FONT]	[FONT=&quot]24/05/2018[/FONT]	[FONT=&quot]4[/FONT]	[FONT=&quot]09/05/2018[/FONT]	[FONT=&quot]13:09:52[/FONT]	[FONT=&quot]Jane Doe[/FONT]	[FONT=&quot]Individual[/FONT]	[FONT=&quot]New Form[/FONT]
[FONT=&quot]ROW 5[/FONT]	[FONT=&quot]24/05/2018[/FONT]	[FONT=&quot]8[/FONT]	[FONT=&quot]20/05/2018[/FONT]	[FONT=&quot]12:55:56[/FONT]	[FONT=&quot]Jane Smith[/FONT]	[FONT=&quot]Individual[/FONT]	[FONT=&quot]New Form[/FONT]

And like this in Dormant

	[FONT=&quot]A[/FONT]	[FONT=&quot]B[/FONT]	[FONT=&quot]C[/FONT]	[FONT=&quot]D[/FONT]	[FONT=&quot]E[/FONT]	[FONT=&quot]F[/FONT]	[FONT=&quot]G[/FONT]
[FONT=&quot]ROW 1[/FONT]	[FONT=&quot]Date Imported[/FONT]	[FONT=&quot]UserID[/FONT]	[FONT=&quot]submit_date[/FONT]	[FONT=&quot]submit_time[/FONT]	[FONT=&quot]Name[/FONT]	[FONT=&quot]Individual[/FONT]	[FONT=&quot]New Form[/FONT]
[FONT=&quot]ROW 2[/FONT]	[FONT=&quot]09/05/2018[/FONT]	[FONT=&quot]8[/FONT]	[FONT=&quot]08/05/2018[/FONT]	[FONT=&quot]12:52:48[/FONT]	[FONT=&quot]Jane Smith[/FONT]	[FONT=&quot]Individual[/FONT]	[FONT=&quot]New Form[/FONT]
[FONT=&quot]ROW 3[/FONT]	[FONT=&quot]24/05/2018[/FONT]	[FONT=&quot]8[/FONT]	[FONT=&quot]20/05/2018[/FONT]	[FONT=&quot]12:52:48[/FONT]	[FONT=&quot]Jane Smith[/FONT]	[FONT=&quot]Individual[/FONT]	[FONT=&quot]New Form[/FONT]

I have removed the colours as they were only for your reference

Hope this make sence.

Thanks for having a look

Sharid · May 10, 2018

I took this code from the web and made minor changes, It kind of does what I want. It matches the data in 3 columns and then deletes all matched rows, keeping 1 record, the first one.

My third column would be the time column, if its greater that other matched records keep that record and move others to "Dormant"

Code:

 Dim lastrow As Long

    With ThisWorkbook.Worksheets("Sheet4")
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            lastrow = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).row
        Else
            lastrow = 1
        End If

        'Array(1, 2, 3) means 1 - for A, 2 for B and 3 for C columns
        .Range("A1:E" & lastrow).RemoveDuplicates Columns:=Array(1, 2, 3), _
            Header:=xlYes
    End With

still stuck on this one

MickG · May 10, 2018

Try this:-

Code:

[COLOR=navy]Sub[/COLOR] MG10May05
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, n [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Dt [COLOR=navy]As[/COLOR] Date, Q [COLOR=navy]As[/COLOR] Variant, t
[COLOR=navy]With[/COLOR] Sheets("Customer Records")
    [COLOR=navy]Set[/COLOR] Rng = .Range("B1", .Range("B" & Rows.Count).End(xlUp))
[COLOR=navy]End[/COLOR] With
[COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
        [COLOR=navy]If[/COLOR] Not .Exists(Dn.Value) [COLOR=navy]Then[/COLOR]
            .Add Dn.Value, Array(Dn, Dn)
        [COLOR=navy]Else[/COLOR]
            Q = .Item(Dn.Value)
                Dt = Q(0).Offset(, 1) + Q(0).Offset(, 2)
                [COLOR=navy]If[/COLOR] Dn.Offset(, 1) + Dn.Offset(, 2) > Dt [COLOR=navy]Then[/COLOR] [COLOR=navy]Set[/COLOR] Q(0) = Dn
                [COLOR=navy]Set[/COLOR] Q(1) = Union(Q(1), Dn)
            .Item(Dn.Value) = Q
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR]

[COLOR=navy]Dim[/COLOR] K [COLOR=navy]As[/COLOR] Variant, p [COLOR=navy]As[/COLOR] Variant, nRng [COLOR=navy]As[/COLOR] Range, Ac [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] c [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
ReDim Ray(1 To Rng.Count, 1 To 8)
Ray(1, 1) = "Date Imported": Ray(1, 2) = "UserID": Ray(1, 3) = "Submit Date": Ray(1, 4) = "Submit Time"
Ray(1, 5) = "Name": Ray(1, 6) = "Individual": Ray(1, 7) = "New Form"
c = 1
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] p [COLOR=navy]In[/COLOR] .Item(K)(1)
        [COLOR=navy]If[/COLOR] Not p.Address = .Item(K)(0).Address [COLOR=navy]Then[/COLOR]
            [COLOR=navy]If[/COLOR] nRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR] [COLOR=navy]Set[/COLOR] nRng = p Else [COLOR=navy]Set[/COLOR] nRng = Union(nRng, p)
                c = c + 1
                [COLOR=navy]For[/COLOR] Ac = 1 To 7
                    [COLOR=navy]If[/COLOR] Ac = 4 [COLOR=navy]Then[/COLOR]
                        Ray(c, Ac) = Format(p.Offset(, -(2 - Ac)), "hh:mm:ss")
                    [COLOR=navy]Else[/COLOR]
                        Ray(c, Ac) = p.Offset(, -(2 - Ac))
                    [COLOR=navy]End[/COLOR] If
                 [COLOR=navy]Next[/COLOR] Ac
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] p
[COLOR=navy]Next[/COLOR] K
[COLOR=navy]End[/COLOR] With
[COLOR=navy]If[/COLOR] Not nRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR] nRng.EntireRow.Delete
[COLOR=navy]With[/COLOR] Sheets("Dormant").Range("A1").Resize(c, 7)
   .Value = Ray
   .Borders.Weight = 2
   .Columns.AutoFit
[COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

Sharid · May 10, 2018

Mick as always your code is super, I could never have written that. Its 99% right, also can you confirm the following

1) The bit in RED these are the headings content that are moved to dormant, if i want to move more, as the range is large do I jut keep adding Ray(1, 7) = "New Form" so the next one will read :Ray(1, 8) = "Address" and also increase this - With Sheets("Dormant").Range("A1").Resize(c, 7)

2) When it moves the records to dormant, it is NOT the next blank row, it start from a1

3) When it moves to "Dormant" the heading is also moved, if you update this code can the NEW code pastes in the next blank row and can It not keep having the headings.

Code:

Dim Rng As Range, Dn As Range, n As Long, Dt As Date, Q As Variant, t
With Sheets("Sheet1")
    Set Rng = .Range("B1", .Range("B" & Rows.Count).End(xlUp))
End With
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
    For Each Dn In Rng
        If Not .Exists(Dn.Value) Then
            .Add Dn.Value, Array(Dn, Dn)
        Else
            Q = .Item(Dn.Value)
                Dt = Q(0).Offset(, 1) + Q(0).Offset(, 2)
                If Dn.Offset(, 1) + Dn.Offset(, 2) > Dt Then Set Q(0) = Dn
                Set Q(1) = Union(Q(1), Dn)
            .Item(Dn.Value) = Q
        End If
    Next

Dim K As Variant, p As Variant, nRng As Range, Ac As Long, c As Long
ReDim Ray(1 To Rng.Count, 1 To 8)
[COLOR=#ff0000]Ray(1, 1) = "Date Imported": Ray(1, 2) = "UserID": Ray(1, 3) = "Submit Date": Ray(1, 4) = "Submit Time"
Ray(1, 5) = "Name": Ray(1, 6) = "Individual": Ray(1, 7) = "New Form"[/COLOR]
c = 1
For Each K In .keys
    For Each p In .Item(K)(1)
        If Not p.Address = .Item(K)(0).Address Then
            If nRng Is Nothing Then Set nRng = p Else Set nRng = Union(nRng, p)
                c = c + 1
                For Ac = 1 To 7
                    If Ac = 4 Then
                        Ray(c, Ac) = Format(p.Offset(, -(2 - Ac)), "hh:mm:ss")
                    Else
                        Ray(c, Ac) = p.Offset(, -(2 - Ac))
                    End If
                 Next Ac
        End If
    Next p
Next K
End With
If Not nRng Is Nothing Then nRng.EntireRow.Delete
With Sheets("Dormant").Range("A1").Resize[COLOR=#ff0000](c, 7)[/COLOR]
   .Value = Ray
   .Borders.Weight = 2
   .Columns.AutoFit
End With

MickG · May 10, 2018

This code should now delete duplicates as before , but Now place header on sheet "Dormant" ony in row1, and subsequent data will start from the previous last line in sheet "Dormant".
The code should also cover extended columns from sheet "Customer Reports".

Code:

[COLOR="Navy"]Sub[/COLOR] MG10May10
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Dt [COLOR="Navy"]As[/COLOR] Date, Q [COLOR="Navy"]As[/COLOR] Variant, t
[COLOR="Navy"]Dim[/COLOR] cLst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] dLst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("Customer Records")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range("B1", .Range("B" & Rows.Count).End(xlUp))
    cLst = Cells("1", Columns.Count).End(xlToLeft).Column
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
            .Add Dn.Value, Array(Dn, Dn)
        [COLOR="Navy"]Else[/COLOR]
            Q = .Item(Dn.Value)
                Dt = Q(0).Offset(, 1) + Q(0).Offset(, 2)
                [COLOR="Navy"]If[/COLOR] Dn.Offset(, 1) + Dn.Offset(, 2) > Dt [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Set[/COLOR] Q(0) = Dn
                [COLOR="Navy"]Set[/COLOR] Q(1) = Union(Q(1), Dn)
            .Item(Dn.Value) = Q
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR]

[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, p [COLOR="Navy"]As[/COLOR] Variant, nRng [COLOR="Navy"]As[/COLOR] Range, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
ReDim Ray(1 To Rng.Count, 1 To cLst)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] p [COLOR="Navy"]In[/COLOR] .Item(K)(1)
        [COLOR="Navy"]If[/COLOR] Not p.Address = .Item(K)(0).Address [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Set[/COLOR] nRng = p Else [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, p)
                c = c + 1
                [COLOR="Navy"]For[/COLOR] Ac = 1 To cLst
                    [COLOR="Navy"]If[/COLOR] Ac = 4 [COLOR="Navy"]Then[/COLOR]
                        Ray(c, Ac) = Format(p.Offset(, -(2 - Ac)), "hh:mm:ss")
                    [COLOR="Navy"]Else[/COLOR]
                        Ray(c, Ac) = p.Offset(, -(2 - Ac))
                    [COLOR="Navy"]End[/COLOR] If
                 [COLOR="Navy"]Next[/COLOR] Ac
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] p
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
    nRng.EntireRow.Delete
    [COLOR="Navy"]With[/COLOR] Sheets("Dormant")
        .Range("A1").Resize(, cLst).Value = Rng.Resize(, cLst).Value
        dLst = .Range("A" & Rows.Count).End(xlUp).Row
        [COLOR="Navy"]With[/COLOR] .Range("A" & dLst + 1).Resize(c, cLst)
            .Value = Ray
            .Borders.Weight = 2
            .Columns.AutoFit
        [COLOR="Navy"]End[/COLOR] With
    [COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

Sharid · May 10, 2018

MickG

This is super, thanks for sorting this out for me again. As always your a life saver

MickG · May 11, 2018

You're welcome

Remove Duplicate depending on date and time

Sharid

Well-known Member

Excel Facts

Sharid

Well-known Member

MickG

MrExcel MVP

Sharid

Well-known Member

MickG

MrExcel MVP

Sharid

Well-known Member

MickG

MrExcel MVP

Similar threads

Forum statistics

Share this page

Remove Duplicate depending on date and time

Sharid

Well-known Member

Excel Facts

Sharid

Well-known Member

MickG

MrExcel MVP

Sharid

Well-known Member

MickG

MrExcel MVP

Sharid

Well-known Member

MickG

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock