MS Excel – How to create a VBA to remove duplicates with dates within 21 days keeping the most recent duplicate

[Kylie19]

Hello,


I have done a fair bit of research with no luck and hoping to get some assistance.


I have data from A3 to W10,000 and I am looking for a macro that can remove rows where the name in column C is a duplicate and the date in column W is within 21 days of another date with the duplicated name and NOT the most recent date in that period - please see below extract for a better explanation:


Below is a sample of the data currently (Name is column C and Date is column W)


Name …. Date


SMITH, Tom …. 01/01/2019


SMITH, Tom …. 02/01/2019


SMITH Tom …. 03/01/2019


JONES, Terry …. 12/03/2019


JONES Terry …. 13/03/2019


SMITH, Tom …. 01/06/2019


SMITH, Tom …. 02/06/2019


JONES Terry …. 15/06/2019




Below is the data I would like shown


Name …. Date


SMITH Tom …. 03/01/2019


JONES Terry …. 13/03/2019


SMITH, Tom …. 02/06/2019


JONES Terry …. 15/06/2019


I am grateful for any assistance or guidance provided!


Thank you

 

[onlyadrafter]

Hello,

IF you don't want the most recent date, then how is SMITH, Tom date 2/6/19? Isn't this the most recent date? His others are 1/1/19, 2/1/19, 1/6/19 and 2/6/19. Shouldn't the answer be 1/6/19? Or am I missing something regarding the within 21 days bit?

 

[Kylie19]

Hello,

Sorry for the confusion! So for SMITH, as 01/01/19, 02/01/19 and 03/01/19 are within 21 days I want to keep the most recent one (03/01/19)and delete the other two. SMITH then has other dates of 01/06/19 and 02/06/19 which are more than 21 days from his first lot of dates so I also want to keep the most recent one (02/06/19) as well as the 03/01/19.

Hope that explains it better!

 

[onlyadrafter]

Hello,

I think there may be an issue with same names but with and without commas.

Sub last_date()
    Columns("C:C").Replace What:=",", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    For MY_ROWS = 1 To Range("C" & Rows.Count).End(xlUp).Row
        MY_NAME = Range("C" & MY_ROWS).Value
        MY_DATE = Range("W" & MY_ROWS).Value
        For MY_NEXT_ROWS = MY_ROWS + 1 To Range("C" & Rows.Count).End(xlUp).Row
            If Range("C" & MY_NEXT_ROWS).Value = MY_NAME And Not (IsEmpty(Range("C" & MY_NEXT_ROWS).Value)) Then
                If DateValue(Range("W" & MY_NEXT_ROWS).Value) <= DateValue(MY_DATE + 21) Then
                    MY_DATE = Range("W" & MY_NEXT_ROWS).Value
                    Range("C" & MY_NEXT_ROWS & ":W" & MY_NEXT_ROWS).ClearContents
                End If
            End If
        Next MY_NEXT_ROWS
    Range("AE" & Rows.Count).End(xlUp).Offset(1, 0).Value = MY_NAME
    Range("AF" & Rows.Count).End(xlUp).Offset(1, 0).Value = MY_DATE
    MY_DATE = ""
    Next MY_ROWS
End Sub

lets use this as the starting point. Not sure where you want the results to go.

 

[Kylie19]

Thank you!!

Is there a way to copy the data from Column A to W to a new sheet for the ones that match the criteria?

 

[onlyadrafter]

Hello,

try either of these

Sub last_date()
    Columns("C:C").Replace What:=",", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    For MY_ROWS = 1 To Range("C" & Rows.Count).End(xlUp).Row
        MY_NAME = Range("C" & MY_ROWS).Value
        MY_DATE = Range("W" & MY_ROWS).Value
        For MY_NEXT_ROWS = MY_ROWS + 1 To Range("C" & Rows.Count).End(xlUp).Row
            If Range("C" & MY_NEXT_ROWS).Value = MY_NAME And Not (IsEmpty(Range("C" & MY_NEXT_ROWS).Value)) Then
                If DateValue(Range("W" & MY_NEXT_ROWS).Value) <= DateValue(MY_DATE + 21) Then
                    MY_DATE = Range("W" & MY_NEXT_ROWS).Value
                    Range("C" & MY_NEXT_ROWS & ":W" & MY_NEXT_ROWS).ClearContents
                End If
            End If
        Next MY_NEXT_ROWS
    MY_DATE = ""
    Next MY_ROWS
    Range("A1:W" & Range("W" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeConstants, 23).Copy
    Sheets("Sheet2").Range("A1").PasteSpecial (xlPasteAll)
End Sub

Sub last_date_2()
    Columns("C:C").Replace What:=",", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    For MY_ROWS = 1 To Range("C" & Rows.Count).End(xlUp).Row
        MY_NAME = Range("C" & MY_ROWS).Value
        MY_DATE = Range("W" & MY_ROWS).Value
        For MY_NEXT_ROWS = MY_ROWS + 1 To Range("C" & Rows.Count).End(xlUp).Row
            If Range("C" & MY_NEXT_ROWS).Value = MY_NAME And Not (IsEmpty(Range("C" & MY_NEXT_ROWS).Value)) Then
                If DateValue(Range("W" & MY_NEXT_ROWS).Value) <= DateValue(MY_DATE + 21) Then
                    MY_DATE = Range("W" & MY_NEXT_ROWS).Value
                    Range("C" & MY_NEXT_ROWS & ":W" & MY_NEXT_ROWS).ClearContents
                End If
            End If
        Next MY_NEXT_ROWS
    MY_DATE = ""
    Next MY_ROWS
    For MY_ROWS = 1 To Range("C" & Rows.Count).End(xlUp).Row
        If Not (IsEmpty(Range("c" & MY_ROWS).Value)) Then
            Range("A" & MY_ROWS & ":W" & MY_ROWS).Copy
            Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteAll)
        End If
    Next MY_ROWS
End Sub

Change Sheet2 to your destination sheet name.