Merging Rows Into One New Updated Row

[hakunamatata167]

Hi All,

I have a large database which I am working on and one part I'm stuck on is merging rows to give one result.

i.e. here is some mock data:

Date	Time	Speciality	Location	Person
15/04/18	morning	TeamCap	Brooklyn	Captain America
15/04/18	afternoon	TeamCap	Brooklyn	Captain America
15/04/18	evening	TeamCap	Brooklyn	Captain America
15/04/18	morning	TeamStark	Long Island	Iron Man
15/04/18	afternoon	TeamStark	Long Island	Iron Man

<tbody>
</tbody>

And here is what I would like:

Date	Time	Speciality	Location	Person
15/04/18	Triple Session	TeamCap	Brooklyn	Captain America
15/04/18	All Day	TeamStark	Long Island	Iron Man

<tbody>
</tbody>

As you can see, basically I need a way to merge cells and if they match a criteria in the time column, replace this with a summary term - for example morning+afternoon+evening would equal triple session; morning+afternoon would equal all day

Thanks for any help and ideas

 

[Peter_SSs]

morning+afternoon+evening would equal triple session; morning+afternoon would equal all day

What would afternoon+evening be?
What would morning+evening be?

 

[MickG]

Try this for Results starting "G1":-
NB:- Depending on other "Session" options further clarification may be needed !!!

[COLOR="Navy"]Sub[/COLOR] MG15Apr30
[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, Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Num [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, nTxt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("D1"), Range("D" & 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
    Num = 0
    [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] Dn.Offset(, -2).Value
        [COLOR="Navy"]Case[/COLOR] "morning": Num = 1
        [COLOR="Navy"]Case[/COLOR] "afternoon": Num = 2
        [COLOR="Navy"]Case[/COLOR] "evening": Num = 4
        [COLOR="Navy"]Case[/COLOR] Else: Num = 0
    [COLOR="Navy"]End[/COLOR] Select
        [COLOR="Navy"]If[/COLOR] Not .Exists(Txt) [COLOR="Navy"]Then[/COLOR]
            .Add Txt, Array(Num, Dn.Offset(, -3))
        [COLOR="Navy"]Else[/COLOR]
            Q = .Item(Txt)
            Q(0) = Q(0) + Num
            .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"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] True
        [COLOR="Navy"]Case[/COLOR] .Item(K)(0) = 1: nTxt = "morning"
        [COLOR="Navy"]Case[/COLOR] .Item(K)(0) = 2: nTxt = "afternoon"
        [COLOR="Navy"]Case[/COLOR] .Item(K)(0) = 4: nTxt = "evening"
        [COLOR="Navy"]Case[/COLOR] .Item(K)(0) = 3:: nTxt = "All Day"
        [COLOR="Navy"]Case[/COLOR] .Item(K)(0) = 7:: nTxt = "Triple session"
    [COLOR="Navy"]End[/COLOR] Select
    c = c + 1
    [COLOR="Navy"]For[/COLOR] ac = 0 To 4
        [COLOR="Navy"]If[/COLOR] ac = 1 And Not .Item(K)(0) = 0 [COLOR="Navy"]Then[/COLOR]
        Cells(c, 7 + ac) = nTxt
        [COLOR="Navy"]Else[/COLOR]
        Cells(c, 7 + ac) = IIf(ac = 0, Format(.Item(K)(1).Offset(, ac), "dd/mm/yyy"), .Item(K)(1).Offset(, ac))
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] ac
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick