Finding Min/Max based on multiple criteria (NOT USING ARRAY)

[bmd205]

Hello-

I've been searching forums all morning trying to find a way to find a way to get the minimum value using two criteria. Here's a sample of what my data looks like, and ideally what I'd like to see as a result.

[TABLE="width: 500"]
<tbody>[TR]
[TD]Case #
[/TD]
[TD]Size
[/TD]
[TD]Date
[/TD]
[/TR]
[TR]
[TD]1
[/TD]
[TD]Small
[/TD]
[TD]201501
[/TD]
[/TR]
[TR]
[TD]1
[/TD]
[TD]Small
[/TD]
[TD]201512
[/TD]
[/TR]
[TR]
[TD]1
[/TD]
[TD]Large
[/TD]
[TD]201503
[/TD]
[/TR]
[TR]
[TD]1
[/TD]
[TD]Large
[/TD]
[TD]201508
[/TD]
[/TR]
[TR]
[TD]1
[/TD]
[TD]Large
[/TD]
[TD]201511
[/TD]
[/TR]
[TR]
[TD]2
[/TD]
[TD]Large
[/TD]
[TD]201507
[/TD]
[/TR]
[TR]
[TD]2
[/TD]
[TD]Large
[/TD]
[TD]201511
[/TD]
[/TR]
[TR]
[TD]2
[/TD]
[TD]Small
[/TD]
[TD]201503
[/TD]
[/TR]
[TR]
[TD]2
[/TD]
[TD]Small
[/TD]
[TD]201508
[/TD]
[/TR]
[TR]
[TD]2
[/TD]
[TD]Small
[/TD]
[TD]201501
[/TD]
[/TR]
</tbody>[/TABLE]

Ideal output:
[TABLE="width: 500"]
<tbody>[TR]
[TD]Case #
[/TD]
[TD]Size
[/TD]
[TD]Min
[/TD]
[TD]Max
[/TD]
[/TR]
[TR]
[TD]1
[/TD]
[TD]Small
[/TD]
[TD]201501
[/TD]
[TD]201512
[/TD]
[/TR]
[TR]
[TD]1
[/TD]
[TD]Large
[/TD]
[TD]201503
[/TD]
[TD]201511
[/TD]
[/TR]
[TR]
[TD]2
[/TD]
[TD]Small
[/TD]
[TD]201501
[/TD]
[TD]201508
[/TD]
[/TR]
[TR]
[TD]2
[/TD]
[TD]Large
[/TD]
[TD]201507
[/TD]
[TD]201511
[/TD]
[/TR]
</tbody>[/TABLE]

I am familiar with Arrays, and I have done a Max(if( nested statement to get the results I need, but I'm also building a macro that will loop through my output (could be 100k+ rows) and the Array Formula just doesn't seem efficient.

Is there a way to write some VBA code to loop through and find the min based on two criteria (Case # and Size)??

 

[MickG]

Try this:-
Results start "E1"

[COLOR="Navy"]Sub[/COLOR] MG12Nov19
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Ray [COLOR="Navy"]As[/COLOR] Variant, Q [COLOR="Navy"]As[/COLOR] Variant, K [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] oMin [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Ray = ActiveSheet.Range("A1").CurrentRegion
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] Rw = 2 To UBound(Ray)
    [COLOR="Navy"]If[/COLOR] Not .Exists(Ray(Rw, 1) & "," & Ray(Rw, 2)) [COLOR="Navy"]Then[/COLOR]
        ReDim nray(1 To UBound(Ray, 1))
        nray(1) = Ray(Rw, 3)
        .Add Ray(Rw, 1) & "," & Ray(Rw, 2), Array(nray, 1)
    [COLOR="Navy"]Else[/COLOR]
        Q = .Item(Ray(Rw, 1) & "," & Ray(Rw, 2))
        Q(1) = Q(1) + 1
        Q(0)(Q(1)) = Ray(Rw, 3)
       .Item(Ray(Rw, 1) & "," & Ray(Rw, 2)) = Q
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
ReDim r(1 To UBound(Ray, 1), 1 To 4)
r(1, 1) = "Case #": r(1, 2) = "Size": r(1, 3) = "Min": r(1, 4) = "Max"
c = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    c = c + 1
    r(c, 1) = Split(K, ",")(0)
    r(c, 2) = Split(K, ",")(1)
    r(c, 3) = Application.Min(.Item(K)(0))
    r(c, 4) = Application.Max(.Item(K)(0))
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] With
Range("E1").Resize(c, 4) = r
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick