Keeping several instances of the same value

[chocolatelove]

[TABLE="class: outer_border, width: 500"]
<tbody>[TR]
[TD]Report ID
[/TD]
[TD]Date
[/TD]
[/TR]
[TR]
[TD]1234
[/TD]
[TD]11/16/2017
[/TD]
[/TR]
[TR]
[TD]1234
[/TD]
[TD]9/26/2016
[/TD]
[/TR]
[TR]
[TD]1234
[/TD]
[TD]10/11/2017
[/TD]
[/TR]
[TR]
[TD]1234
[/TD]
[TD]8/15/2012
[/TD]
[/TR]
[TR]
[TD]etc.
[/TD]
[TD]etc.
[/TD]
[/TR]
</tbody>[/TABLE]
Hello,

See example above
I have a large amount of data. Column A (Report ID) is duplicated. Column B (Date) is unique. I want to keep only the 5 latest dates and delete the rest.

What function/filter can I use?

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG17Nov08
[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] K [COLOR="Navy"]As[/COLOR] Variant, R [COLOR="Navy"]As[/COLOR] Range, nRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
[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, Dn.Offset(, 1)
    [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn.Offset(, 1))
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] .Item(K)
      [COLOR="Navy"]If[/COLOR] .Item(K).Count > 5 [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]If[/COLOR] R.Value < Application.Large(.Item(K), 5) [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Set[/COLOR] nRng = R Else [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, R)
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
 [COLOR="Navy"]Next[/COLOR] R
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] nRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[chocolatelove]

Hello,

The code worked on sample size but now its not working (I have about 104000 rows).

Try this:-

[COLOR=navy]Sub[/COLOR] MG17Nov08
[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] K [COLOR=navy]As[/COLOR] Variant, R [COLOR=navy]As[/COLOR] Range, nRng [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
[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, Dn.Offset(, 1)
    [COLOR=navy]Else[/COLOR]
        [COLOR=navy]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn.Offset(, 1))
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR]

[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] R [COLOR=navy]In[/COLOR] .Item(K)
      [COLOR=navy]If[/COLOR] .Item(K).Count > 5 [COLOR=navy]Then[/COLOR]
        [COLOR=navy]If[/COLOR] R.Value < Application.Large(.Item(K), 5) [COLOR=navy]Then[/COLOR]
            [COLOR=navy]If[/COLOR] nRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR] [COLOR=navy]Set[/COLOR] nRng = R Else [COLOR=navy]Set[/COLOR] nRng = Union(nRng, R)
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]End[/COLOR] If
 [COLOR=navy]Next[/COLOR] R
[COLOR=navy]Next[/COLOR] K
[COLOR=navy]If[/COLOR] Not nRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR] nRng.EntireRow.Delete
[COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[MickG]

Try this:-
This code takes about 30secs to run.

[COLOR="Navy"]Sub[/COLOR] MG20Nov45
[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] K [COLOR="Navy"]As[/COLOR] Variant, R [COLOR="Navy"]As[/COLOR] Range, nRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
[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, Dn.Offset(, 1)
    [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn.Offset(, 1))
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] .Item(K)
      [COLOR="Navy"]If[/COLOR] .Item(K).Count > 5 [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]If[/COLOR] R.Value < Application.Large(.Item(K), 5) [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Set[/COLOR] nRng = R Else [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, R)
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
 [COLOR="Navy"]Next[/COLOR] R
    [COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
        nRng.ClearContents
        [COLOR="Navy"]Set[/COLOR] nRng = Nothing
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] K
rng.Offset(, 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[chocolatelove]

The code gives an error at the second last line- "Run Time Error" No cells were found.

 

[MickG]

Try adding the line in red:-

[COLOR="#FF0000"][B]On Error Resume Next
[/B][/COLOR]Rng.Offset(, 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete