Comparing Dates

[Tsubarov]

Hey guys,

I'm kinda stuck on this one. I need a macro to get from the first picture, to the second.

Basically, if there are 2 or more 'c_ccontact' cells with the same value, i need to compare the date's in those rows, and delete the rows which don't have the latest date.

|
|
\ /

Thanks in advance !

 

[Andrew Poulsom]

Welcome to MrExcel.

You could create a pivot table with category and contact as row fields and Max of date as the data field.

 

[Tsubarov]

Hi Andrew, thanks for replying.
The problem is i'm making this for somebody who isn't familiar with pivot tables, and this data gets updates every now and then. So he wouldn't be able to reproduce the pivot table. I'm really thinking about a macro. I was thinking something along the lines of filling an array with unique contact data, or something like that anyway.

 

[MickG]

Try this:-

[COLOR=navy]Sub[/COLOR] MG05Jul08
[COLOR=navy]Dim[/COLOR] Rng         [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Dn          [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] nRng        [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Q
[COLOR=navy]Dim[/COLOR] K           [COLOR=navy]As[/COLOR] Variant
[COLOR=navy]Dim[/COLOR] Rw          [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] R           [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Set[/COLOR] Rng = Range(Range("C2"), Range("C" & 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, Array(Dn, Dn)
        [COLOR=navy]Else[/COLOR]
            Q = .Item(Dn.value)
            [COLOR=navy]If[/COLOR] Dn.Offset(, -2) > Q(0).Offset(, -2) [COLOR=navy]Then[/COLOR]
            [COLOR=navy]Set[/COLOR] Q(0) = Dn
            [COLOR=navy]End[/COLOR] If
            [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]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Rw [COLOR=navy]In[/COLOR] .Item(K)(1).Areas
    [COLOR=navy]If[/COLOR] Rw.count > 1 [COLOR=navy]Then[/COLOR]
        [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] R [COLOR=navy]In[/COLOR] Rw
            [COLOR=navy]If[/COLOR] Not R.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 = R
                [COLOR=navy]Else[/COLOR]
                    [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]End[/COLOR] If
[COLOR=navy]Next[/COLOR] Rw
[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] If
[COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[Tsubarov]

Hi Mick, thanks for replying !

Your code seems to crash my Excel.
It's been running for about 10 minutes now, and not responding.

 

[MickG]

Sorry about the Crash, can't replicate that, but try this
on limited data.
There was a bit of overkill in the previous code.

[COLOR="Navy"]Sub[/COLOR] MG05Jul44
[COLOR="Navy"]Dim[/COLOR] Rng         [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn          [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] nRng        [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Q
[COLOR="Navy"]Dim[/COLOR] K           [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Rw          [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] R           [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] tRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("C2"), Range("C" & 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]
            [COLOR="Navy"]Set[/COLOR] tRng = Dn
            .Add Dn.value, Array(Dn, tRng)
        [COLOR="Navy"]Else[/COLOR]
            Q = .Item(Dn.value)
            [COLOR="Navy"]If[/COLOR] DateValue(Dn.Offset(, -2)) > DateValue(Q(0).Offset(, -2)) [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"]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)(1)
            [COLOR="Navy"]If[/COLOR] Not R.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 = R
                [COLOR="Navy"]Else[/COLOR]
                    [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] If
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Tsubarov]

Hi Mick,

" If DateValue(Dn.Offset(, -2)) > DateValue(Q(0).Offset(, -2)) Then Set Q(0) = Dn" is giving me an error

a type mismatch

Kind regards

 

[MickG]

Can you paste an example of the data that gives the error.

 

[Tsubarov]

I tried it on the data you see on the first picture I included.

 

[MickG]

Are those dates "Dates or Text" and have you got anything else in that column That is not a Date apart from the Header.
One of the problems with your data is its posted as a Picture , therefore I'm not able to copy it directly into the worksheet.
I have , however copied it manually I can find no problem except when I place Text in that column. When I also get a Type Mismatch.