Remove multiple entries to duplicates in column A but leave max and min values of column B

[Ikouc]

Hi!
I need a macro that can find multiple identical values in column A, then find the min and max values of column B and delete all other rows.
Example:

A worker comes to work and registers at 7:55, at 11:00 he registers for lunch and comes back 30min later. At 16:05 he leaves work and all I need is to remove the lunch time for all the days of the month.

Existing table:

1. jul	07:55
1. jul	11:00
1. jul	11:30
1. jul	16:05
2. jul	07:45
2. jul	11:23
2. jul	11:50
2. jul	16:15
3. jul	07:57
3. jul	11:11
3. jul	11:43
3. jul	16:20

<tbody>
</tbody>

---

Desired table:

1. jul	07:55
1. jul	16:05
2. jul	07:45
2. jul	16:15
3. jul	07:57
3. jul	16:20

<tbody>
</tbody>

If there is no lunch registered, than it should just copy the data... I need it to find min and max values of column B, when more than 2 identical values are found in column A.
I searched for an answer, but all I can find is macros that find either min or max, not both.

Can anybody help me with this? It would be much appreciated.

 

[MickG]

Try this:-

[COLOR=Navy]Sub[/COLOR] MG30Jul12
[COLOR=Navy]Dim[/COLOR] Rng         [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] Dn          [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] K           [COLOR=Navy]As[/COLOR] Variant
[COLOR=Navy]Set[/COLOR] Rng = Range(Range("A1"), 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
    [COLOR=Navy]Else[/COLOR]
        [COLOR=Navy]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
    [COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR]
[COLOR=Navy]Dim[/COLOR] oMax            [COLOR=Navy]As[/COLOR] Date
[COLOR=Navy]Dim[/COLOR] oMin            [COLOR=Navy]As[/COLOR] Date
[COLOR=Navy]Dim[/COLOR] nRng            [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] R               [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] K [COLOR=Navy]In[/COLOR] .keys
oMax = Application.Max(.Item(K).Offset(, 1).Value)
oMin = Application.Min(.Item(K).Offset(, 1).Value)
  [COLOR=Navy]If[/COLOR] .Item(K).Count > 3 [COLOR=Navy]Then[/COLOR]
    [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] R [COLOR=Navy]In[/COLOR] .Item(K).Offset(, 1)
        [COLOR=Navy]If[/COLOR] Not R.Value = oMax And Not R.Value = oMin [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] 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]End[/COLOR] [COLOR=Navy]Sub[/COLOR]

Regards Mick

 

[BGY23]

Hi,

You can do this woth a Pivot table. PM me and i'll send you the Excel sheet.

 

[Ikouc]

Thank you Mick, exactly what I needed, works like a charm :D

 

[Ikouc]

Pivot would work aswell, but I will be sending this sheet to users who don't know excel that much. With a macro I can just place a button... Thanks for the reply!

Regards!

 

[MickG]

You're welcome