Macro to extract min/max/average data from large data set

[sambisu]

I have a large data set (~70,000 rows) that contains temperatures at various dates/times. Column A contains the date/time and B contains temperatures (see below). What I would like to do is create a new data set with just the daily min, max and average temperatures (one line of data for each date). I have a dozen or so such data sets, so I wanted a generic macro that I can apply to any of them and continue to use as additional data is added.

Thanks for any help!

Date/Time	°F
12/31/10 0:26	86.9
12/31/10 0:56	86.9
12/31/10 1:26	86.9
12/31/10 1:56	87.1
12/31/10 2:26	86.9
12/31/10 2:56	86.9
12/31/10 3:26	86.9
12/31/10 3:56	86.9
12/31/10 4:26	86.7

<tbody>
</tbody>

 

[MickG]

Try this:-
Results start "E1"

[COLOR="Navy"]Sub[/COLOR] MG01Sep18
[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] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
Application.ScreenUpdating = False
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not .Exists(DateValue(Dn.Value)) [COLOR="Navy"]Then[/COLOR]
        .Add DateValue(Dn.Value), Dn.Offset(, 1)
    [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]Set[/COLOR] .Item(DateValue(Dn.Value)) = Union(.Item(DateValue(Dn.Value)), Dn.Offset(, 1))
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
Range("E1:H1") = Array("Date", "Max", "Min", "Average")
c = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    c = c + 1
    Cells(c, "E") = K
    Cells(c, "F") = Application.Max(.Item(K))
    Cells(c, "G") = Application.Min(.Item(K))
    Cells(c, "H") = Application.Average(.Item(K))
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] With
Application.ScreenUpdating = True
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[sambisu]

Worked great! Thanks so much!

 

[MickG]

You're welcome