Summarise data recorded by date in date ranges

lukeh88 · Nov 8, 2018

Hi - I've been madly googling this problem and cannot find anything that quite solves it for me. Looking to this forum which has helped me so many times before (although first time posting a question!).

I have data capturing number of hours and pay rate, by person, each day. What I want to do is summarise by each person, with a date range. This will be for thousands of people, so obviously open to VBA.
Example of the data;

	1/01/2018	2/01/2018	3/01/2018	4/01/2018	5/01/2018	6/01/2018	7/01/2018	8/01/2018	9/01/2018	10/01/2018
Person 1	4.5	4.5	4.5	4.5	5	5	5	5	5	5
Person 1	18.10	18.10	18.10	19.00	19.00	19.00	19.00	19.50	19.50	19.50
Person 2	4.5	4.5	4.5	5	5	5	5	5	5	5
Person 2	18.50	18.50	19.00	19.00	19.00	21.50	21.50	21.50	21.50	21.50

Ideal end state;

	Start	End	Hours	Rate
Person 1	1/01/2018	3/01/2018	4.5	18.10
Person 1	4/01/2018	4/01/2018	4.5	19.00
Person 1	5/01/2018	7/01/2018	5	19.00
Person 1	8/01/2018	10/01/2018	5	19.50
Person 2	1/01/2018	2/01/2018	4.5	18.50
Person 2	3/01/2018	3/01/2018	4.5	19.00
Person 2	4/01/2018	5/01/2018	5	19.00
Person 2	6/01/2018	10/01/2018	5	21.50

Would really appreciate any assistance here.

Thanks
Luke

MickG · Nov 8, 2018

Try this , Result on sheet2.

Code:

[COLOR="Navy"]Sub[/COLOR] MG08Nov19
[COLOR="Navy"]Dim[/COLOR] Ray         [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Ac          [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] n           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic         [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Q           [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Txt         [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] k           [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] p           [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] c           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]

Ray = ActiveSheet.Cells(1).CurrentRegion
 [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
   
   [COLOR="Navy"]For[/COLOR] n = 2 To UBound(Ray, 1) [COLOR="Navy"]Step[/COLOR] 2
        [COLOR="Navy"]For[/COLOR] Ac = 2 To UBound(Ray, 2)
            Txt = Ray(n, Ac) & "," & Ray(n + 1, Ac)
            [COLOR="Navy"]If[/COLOR] Not Dic.exists(Ray(n, 1)) [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Dic(Ray(n, 1)) = CreateObject("Scripting.Dictionary")
            [COLOR="Navy"]End[/COLOR] If
        
        [COLOR="Navy"]If[/COLOR] Not Dic(Ray(n, 1)).exists(Txt) [COLOR="Navy"]Then[/COLOR]
                Dic(Ray(n, 1)).Add (Txt), Array(Ray(1, Ac), Ray(1, Ac))
        [COLOR="Navy"]Else[/COLOR]
            Q = Dic(Ray(n, 1)).Item(Txt)
                Q(1) = Ray(1, Ac)
            Dic(Ray(n, 1)).Item(Txt) = Q
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Ac
    [COLOR="Navy"]Next[/COLOR] n
   
   ReDim nray(1 To UBound(Ray, 1) * UBound(Ray, 2), 1 To 5)
   nray(1, 1) = "Person": nray(1, 2) = "Start": nray(1, 3) = "End"
   nray(1, 4) = "Hours": nray(1, 5) = "Rate"
   c = 1
    
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.Keys
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] p [COLOR="Navy"]In[/COLOR] Dic(k)
             c = c + 1
             nray(c, 1) = k
             nray(c, 2) = Dic(k).Item(p)(0)
             nray(c, 3) = Dic(k).Item(p)(1)
             nray(c, 4) = Split(p, ",")(0)
             nray(c, 5) = Split(p, ",")(1)
        [COLOR="Navy"]Next[/COLOR] p
    [COLOR="Navy"]Next[/COLOR] k
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, 5)
    .Value = nray
    .Columns.AutoFit
    .Borders.Weight = 2
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

lukeh88 · Nov 8, 2018

Thanks Mick,

This works brilliantly. Without realising, additional data points will now come through to add to my problem. I'll give it a try myself but would very much appreciate your guidance, if I were to have another line of data (ie. sales units), what would I need to add to the code?

MickG said:

Try this , Result on sheet2.

Code:

[COLOR=Navy]Sub[/COLOR] MG08Nov19
[COLOR=Navy]Dim[/COLOR] Ray         [COLOR=Navy]As[/COLOR] Variant
[COLOR=Navy]Dim[/COLOR] Ac          [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Dim[/COLOR] n           [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Dim[/COLOR] Dic         [COLOR=Navy]As[/COLOR] Object
[COLOR=Navy]Dim[/COLOR] Q           [COLOR=Navy]As[/COLOR] Variant
[COLOR=Navy]Dim[/COLOR] Txt         [COLOR=Navy]As[/COLOR] [COLOR=Navy]String[/COLOR]
[COLOR=Navy]Dim[/COLOR] k           [COLOR=Navy]As[/COLOR] Variant
[COLOR=Navy]Dim[/COLOR] p           [COLOR=Navy]As[/COLOR] Variant
[COLOR=Navy]Dim[/COLOR] c           [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]

Ray = ActiveSheet.Cells(1).CurrentRegion
 [COLOR=Navy]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
   
   [COLOR=Navy]For[/COLOR] n = 2 To UBound(Ray, 1) [COLOR=Navy]Step[/COLOR] 2
        [COLOR=Navy]For[/COLOR] Ac = 2 To UBound(Ray, 2)
            Txt = Ray(n, Ac) & "," & Ray(n + 1, Ac)
            [COLOR=Navy]If[/COLOR] Not Dic.exists(Ray(n, 1)) [COLOR=Navy]Then[/COLOR]
                [COLOR=Navy]Set[/COLOR] Dic(Ray(n, 1)) = CreateObject("Scripting.Dictionary")
            [COLOR=Navy]End[/COLOR] If
        
        [COLOR=Navy]If[/COLOR] Not Dic(Ray(n, 1)).exists(Txt) [COLOR=Navy]Then[/COLOR]
                Dic(Ray(n, 1)).Add (Txt), Array(Ray(1, Ac), Ray(1, Ac))
        [COLOR=Navy]Else[/COLOR]
            Q = Dic(Ray(n, 1)).Item(Txt)
                Q(1) = Ray(1, Ac)
            Dic(Ray(n, 1)).Item(Txt) = Q
        [COLOR=Navy]End[/COLOR] If
    [COLOR=Navy]Next[/COLOR] Ac
    [COLOR=Navy]Next[/COLOR] n
   
   ReDim nray(1 To UBound(Ray, 1) * UBound(Ray, 2), 1 To 5)
   nray(1, 1) = "Person": nray(1, 2) = "Start": nray(1, 3) = "End"
   nray(1, 4) = "Hours": nray(1, 5) = "Rate"
   c = 1
    
    [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] k [COLOR=Navy]In[/COLOR] Dic.Keys
        [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] p [COLOR=Navy]In[/COLOR] Dic(k)
             c = c + 1
             nray(c, 1) = k
             nray(c, 2) = Dic(k).Item(p)(0)
             nray(c, 3) = Dic(k).Item(p)(1)
             nray(c, 4) = Split(p, ",")(0)
             nray(c, 5) = Split(p, ",")(1)
        [COLOR=Navy]Next[/COLOR] p
    [COLOR=Navy]Next[/COLOR] k
[COLOR=Navy]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, 5)
    .Value = nray
    .Columns.AutoFit
    .Borders.Weight = 2
[COLOR=Navy]End[/COLOR] [COLOR=Navy]With[/COLOR]
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]

Regards Mick

MickG · Nov 9, 2018

Please show example of new data with expected results.
Mick

lukeh88 · Nov 9, 2018

Hi Mick,
Thanks for coming back so quickly - suspect we might be on a significant time difference! Apologies for the revisit, turns out the problem was more complicated than I originally realised. I'm trying to avoid 6 months of pain creating this work around. We have inherently related data points being stored on a daily basis, but they are independent of each other. We need to be able to see what occurred over a given time period, not just on any given day. As such, the data in raw format appears as below;

Person ID	Data type	1/01/2018	2/01/2018	3/01/2018	4/01/2018	5/01/2018	6/01/2018	7/01/2018	8/01/2018	9/01/2018	10/01/2018
1111	Hours	4	4	4	4	4	4	5	5	5	5
1111	Rate	18.5	18.5	18.5	18.5	18.5	19	19	19	19	19
1111	Units of #1	8500	8500	8500	8500	8500	9000	9000	9000	9000	9000
1111	Units of #2	1200	1200	1200	1200	1200	1200	1200	900	900	900
1111	Transport (mins)	35	35	35	35	35	35	35	45	45	45
1111	Data (gb)	1.1	1.1	1.1	1.1	1.1	1.1	1.1	3	3	3
1111	Territory Code	xxyy2	xxyy2	xxyy4	xxyy4	xxyy2	xxyy2	xxyy2	xxyy2	xxyy2	xxyy2
1111	Region Code	xxe	xxe	xxe	yyr	yyr	yyr	yyr	yyr	yyr	yyr
1112	Hours	8	8	8	8	8	8	8	7	7	7
1112	Rate	21	21	21	21	21	21	21	21	21	21
1112	Units of #1	4500	4500	4500	4500	4500	4500	4500	4500	3500	3500
1112	Units of #2	1200	1200	1200	1200	1200	1200	2100	2100	2100	2100
1112	Transport (mins)	15	15	15	15	15	15	15	15	15	15
1112	Data (gb)	1.1	1.1	1.1	1.1	2.5	2.5	2.5	3	3	3
1112	Territory Code	xxyy2	xxyy2	xxyy4	xxyy4	xxyy4	xxyy4	xxyy4	xxyy5	xxyy5	xxyy5
1112	Region Code	xxq	xxq	xxq	xxq	xxq	xxq	xxq	xxq	xx4	xx4

The output should look like

Person ID	Start	End	Hours	Rate	Units of #1	Units of #2	Transport (mins)	Data (gb)	Territory Code	Region Code
1111	1/01/2018	3/01/2018	4	18.5	8500	1200	35	1.1	xxyy4	xxe
1111	4/01/2018	4/01/2018	4	18.5	8500	1200	35	1.1	xxyy4	yyr
1111	5/01/2018	5/01/2018	4	18.5	8500	1200	35	1.1	xxyy2	yyr
1111	6/01/2018	6/01/2018	4	19	9000	1200	35	1.1	xxyy2	yyr
1111	7/01/2018	7/01/2018	5	19	9000	1200	35	1.1	xxyy2	yyr
1111	8/01/2018	10/01/2018	5	19	9000	900	45	3	xxyy2	yyr

Any thoughts appreciated. Thank you again

MickG · Nov 14, 2018

Sorry for late reply:-
Try this for results in sheet2.

Code:

[COLOR="Navy"]Sub[/COLOR] MG14Nov14
[COLOR="Navy"]Dim[/COLOR] Ray         [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Ac          [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] n           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic         [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Q           [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Txt         [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] k           [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] p           [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] c           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]

Ray = ActiveSheet.Cells(1).CurrentRegion
 [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
   
   [COLOR="Navy"]For[/COLOR] n = 2 To UBound(Ray, 1) [COLOR="Navy"]Step[/COLOR] 8
        [COLOR="Navy"]For[/COLOR] Ac = 3 To UBound(Ray, 2)
           [COLOR="Navy"]With[/COLOR] Application
                Txt = Join(.Transpose(.Index(Ray, Evaluate("row(" & n & ":" & n + 7 & ")"), Ac)), ",")
            [COLOR="Navy"]End[/COLOR] With
            [COLOR="Navy"]If[/COLOR] Not Dic.exists(Ray(n, 1)) [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Dic(Ray(n, 1)) = CreateObject("Scripting.Dictionary")
            [COLOR="Navy"]End[/COLOR] If
        
        [COLOR="Navy"]If[/COLOR] Not Dic(Ray(n, 1)).exists(Txt) [COLOR="Navy"]Then[/COLOR]
                Dic(Ray(n, 1)).Add (Txt), Array(Ray(1, Ac), Ray(1, Ac))
        [COLOR="Navy"]Else[/COLOR]
            Q = Dic(Ray(n, 1)).Item(Txt)
                Q(1) = Ray(1, Ac)
            Dic(Ray(n, 1)).Item(Txt) = Q
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Ac
    [COLOR="Navy"]Next[/COLOR] n
   
   ReDim nRay(1 To UBound(Ray, 1) * UBound(Ray, 2), 1 To 11)
   nRay(1, 1) = "Person": nRay(1, 2) = "Start": nRay(1, 3) = "End"
   nRay(1, 4) = "Hours": nRay(1, 5) = "Rate": nRay(1, 6) = "Units of [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] "
   nRay(1, 7) = "Units of [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=2]#2[/URL] ": nRay(1, 8) = "Transport (mins)"
   nRay(1, 9) = "Data (gb)": nRay(1, 10) = "Territory Code": nRay(1, 11) = "Region Code"
    c = 1
    
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.Keys
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] p [COLOR="Navy"]In[/COLOR] Dic(k)
             c = c + 1
             nRay(c, 1) = k
             nRay(c, 2) = Dic(k).Item(p)(0)
             nRay(c, 3) = Dic(k).Item(p)(1)
             nRay(c, 4) = Split(p, ",")(0)
             nRay(c, 5) = Split(p, ",")(1)
             nRay(c, 6) = Split(p, ",")(2)
             nRay(c, 7) = Split(p, ",")(3)
             nRay(c, 8) = Split(p, ",")(4)
             nRay(c, 9) = Split(p, ",")(5)
             nRay(c, 10) = Split(p, ",")(6)
             nRay(c, 11) = Split(p, ",")(7)
        [COLOR="Navy"]Next[/COLOR] p
    [COLOR="Navy"]Next[/COLOR] k

[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, 11)
    .Value = nRay
    .Columns.AutoFit
    .Borders.Weight = 2
[COLOR="Navy"]End[/COLOR] With


[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

lukeh88 · Nov 14, 2018

Mick - this has worked perfectly. I'm going to try on a much larger data set, and see how that goes but not expecting errors (unless by my own making frankly). The code is very efficient on my test data.

You have saved me a lot of time!! Thank you!!!

MickG · Nov 15, 2018

You're very welcome

Summarise data recorded by date in date ranges

lukeh88

New Member

Excel Facts

MickG

MrExcel MVP

lukeh88

New Member

MickG

MrExcel MVP

lukeh88

New Member

MickG

MrExcel MVP

lukeh88

New Member

MickG

MrExcel MVP

Similar threads

Forum statistics

Share this page

Summarise data recorded by date in date ranges

New Member

Excel Facts

MrExcel MVP

New Member

MrExcel MVP

New Member

MrExcel MVP

New Member

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock