Macro to flatten the data table

[Miroy72]

Hello all,

I am looking to see if someone will help me create a macro that would flatten a data table (or move the data from rows into columns) by Name and Activity in excel.


Basically I need to go from this (but there will be many different activities per name):

Name - Activity - Start Date - End Date - Hours
John Smith - Vacation - 12/22/2018 - 12/22/2018 -9
John Smith - Vacation - 12/28/2018 - 12/29/2018 - 18
John Smith - Holiday - 01/01/2019 - 01/01/2019 - 9
John Smith - Holiday - 01/21/2019 - 01/21/2019 -9
Matt Sorum - Vacation - 02/01/2019 - 02/02/2019 - 18
Matt Sorum - Vacation -02/05/2019 -02/08/2019 -36

To this:

Name -Activity- Start - End - Hours - Activity - Start - End - Hours
John Smith - Vacation -12/22/2018 -12/22/2018 -9 -Vacation -12/28/2018 - 12/29/2018 - 18
John Smith - Holiday -01/01/2019 - 01/01/2019 - 9- Holiday -1/21/2019 -01/01/2019- 9
Matt Sorum -Vacation - 02/01/2019 - 02/02/2019 -18 -Vacation -02/05/2019 -02/08/2019 36

The macro does not need to create a new worksheet for this. It can just create the new data in the same worksheet starting in column H or just modify the existing data table structure, whatever is easier.

Thanks in advance!

 

[MickG]

Try this:-
NB:- This code wil alter your data !!!

[COLOR="Navy"]Sub[/COLOR] MG24Jan30
[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] Q [COLOR="Navy"]As[/COLOR] Variant, nRng [COLOR="Navy"]As[/COLOR] Range, txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range("A2", 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 = Dn.Value & Dn.Offset(, 1).Value
    [COLOR="Navy"]If[/COLOR] Not .Exists(txt) [COLOR="Navy"]Then[/COLOR]
        .Add txt, Array(Dn, 1)
    [COLOR="Navy"]Else[/COLOR]
        Q = .Item(txt)
        Q(1) = Q(1) + 4
        Dn.Offset(, 1).Resize(, 4).Copy Q(0).Offset(, Q(1))
        Rng(1).Offset(-1, 1).Resize(, 4).Copy Range("A1").Offset(, Q(1))
        [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Set[/COLOR] nRng = Dn Else [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, Dn)
        .Item(txt) = Q
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[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