How to find the earliest and latest date when multiple criteria is met.

[Plumpychunks]

Hi,

Please help.

I have a sheet of data that is outputted from an external source, see below:

[TABLE="width: 200"]
<tbody>[TR]
[TD]Vehicle Reg[/TD]
[TD]AxleType[/TD]
[TD]Axle[/TD]
[TD]Position[/TD]
[TD]Dimension[/TD]
[TD]New/Retread[/TD]
[TD]Brand[/TD]
[TD]Pattern[/TD]
[TD]Event[/TD]
[TD]Mileage[/TD]
[TD]OTD[/TD]
[TD]Date[/TD]
[TD]RTD[/TD]
[TD]Removal[/TD]
[TD]Regrooved[/TD]
[/TR]
[TR]
[TD]abc123[/TD]
[TD]Drive[/TD]
[TD]3[/TD]
[TD]L[/TD]
[TD]295/80R22.5[/TD]
[TD]New[/TD]
[TD]GOODYEAR[/TD]
[TD]KMAX[/TD]
[TD]Fitment[/TD]
[TD]10[/TD]
[TD]24[/TD]
[TD]1.1.2016[/TD]
[TD]24[/TD]
[TD]3[/TD]
[TD]N[/TD]
[/TR]
[TR]
[TD]abc123[/TD]
[TD]Drive[/TD]
[TD]3[/TD]
[TD]L[/TD]
[TD]295/80R22.5[/TD]
[TD]New[/TD]
[TD]GOODYEAR[/TD]
[TD]KMAX[/TD]
[TD]Exam[/TD]
[TD]120000[/TD]
[TD]24[/TD]
[TD]31.12.2017[/TD]
[TD]6[/TD]
[TD]3[/TD]
[TD]N[/TD]
[/TR]
[TR]
[TD]abc123[/TD]
[TD]Drive[/TD]
[TD]3[/TD]
[TD]L[/TD]
[TD]295/80R22.5[/TD]
[TD]New[/TD]
[TD]GOODYEAR[/TD]
[TD]KMAX[/TD]
[TD]Removal[/TD]
[TD]123321[/TD]
[TD]24[/TD]
[TD]1.1.2018[/TD]
[TD]4[/TD]
[TD]3[/TD]
[TD]N[/TD]
[/TR]
[TR]
[TD]789zyx[/TD]
[TD]Carry[/TD]
[TD]3[/TD]
[TD]R[/TD]
[TD]385/65R22.5[/TD]
[TD]New[/TD]
[TD]PIRELLI[/TD]
[TD]AA1[/TD]
[TD]Fitment[/TD]
[TD]10[/TD]
[TD]22[/TD]
[TD]1.1.2012[/TD]
[TD]22[/TD]
[TD]3[/TD]
[TD]N[/TD]
[/TR]
</tbody>[/TABLE]

I would like some VBA to extract the rows that contain the earliest and latest date when columns A,B,C,D,E,G & H are all the same.

I can find methods to extract earliest and latest dates but none that can do it based 7 criteria.

All help would be greatly appreciated.

 

[MickG]

Try this for results on sheet2.

[COLOR="Navy"]Sub[/COLOR] MG01Mar38
[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] txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, Q [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Set[/COLOR] Rng = 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
    txt = Join(Application.Index(Dn.Resize(, 8).Value, 0, Array(1, 2, 3, 4, 5, 7, 8)))
    [COLOR="Navy"]If[/COLOR] Not .Exists(txt) [COLOR="Navy"]Then[/COLOR]
        .Add txt, Array(Dn.Offset(, 11), Dn.Offset(, 11))
    [COLOR="Navy"]Else[/COLOR]
        Q = .Item(txt)
          [COLOR="Navy"]If[/COLOR] Dn.Offset(, 11).Value < Q(0) [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Set[/COLOR] Q(0) = Dn.Offset(, 11)
          [COLOR="Navy"]If[/COLOR] Dn.Offset(, 11).Value > Q(1) [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Set[/COLOR] Q(1) = Dn.Offset(, 11)
        .Item(txt) = 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"]If[/COLOR] Not .Item(K)(0) = .Item(K)(1) [COLOR="Navy"]Then[/COLOR]
        c = c + 1
        Sheets("sheet2").Cells(c, 1).Resize(, 15).Value = .Item(K)(0).Offset(, -11).Resize(, 15).Value
        c = c + 1
        Sheets("sheet2").Cells(c, 1).Resize(, 15).Value = .Item(K)(1).Offset(, -11).Resize(, 15).Value
    [COLOR="Navy"]ElseIf[/COLOR] .Item(K)(0) = .Item(K)(1) [COLOR="Navy"]Then[/COLOR]
        c = c + 1
        Sheets("sheet2").Cells(c, 1).Resize(, 15).Value = .Item(K)(0).Offset(, -11).Resize(, 15).Value
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Plumpychunks]

That IS magic!

Thank you, that has saved me a heap of time.

 

[MickG]

You're welcome