Extract unique values with duplicate

[MrTommey232]

hi everybody
I would love to get your help in either Vba of formula, to get a nice looking report.
here is what my data likes like

time	room 1	room2	room3
9-10	d.l	t.k	n.d
9-10	m.e	n.d	s.h
9-10	l.a	t.g	e.n
10-11		d.l	n.d
10-11	m.e	s.h	t.k
10-11	l.a	e.n	t.g
11-12	d.l	t.k	n.d
11-12	s.h	m.e	e.n
11-12	t.g	l.a

<tbody>
</tbody>

****** id="cke_pastebin" style="position: absolute; top: 207px; width: 1px; height: 1px; overflow: hidden; left: -1000px;">

t.g

<tbody>
</tbody>

</body>And here is what i want to get in the end for every name:
d.l room1 9-10 room2 10-11 room 3 11-12.
n.d room 2 9-10 room 3 10-12.
t.k room 2 9-12.

the biggest issue that I have is, the goning back and forth of names from one room to anther, and cameing back to the same room in a different hour.
for exm. d.l is in room 1 in 9-10 then going to room 2 in 10-11 and then cameing back again to room 1 in 11-12.

Thx for all the help in advance.

Tom.

 

[MickG]

Try this for results on sheet2.

[COLOR="Navy"]Sub[/COLOR] MG31Jan31
[COLOR="Navy"]Dim[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant, Ray [COLOR="Navy"]As[/COLOR] Variant, Dic [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Ray = Cells(1).CurrentRegion.Resize(, 4)
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] n = 2 To UBound(Ray, 1)
    [COLOR="Navy"]For[/COLOR] Ac = 2 To 4
       [COLOR="Navy"]If[/COLOR] Not IsEmpty(Ray(n, Ac)) [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Ray(n, Ac)) [COLOR="Navy"]Then[/COLOR]
            Dic.Add Ray(n, Ac), Ray(1, Ac) & "-" & Ray(n, 1)
        [COLOR="Navy"]Else[/COLOR]
            Dic(Ray(n, Ac)) = Dic(Ray(n, Ac)) & "," & Ray(1, Ac) & "-" & Ray(n, 1)
        [COLOR="Navy"]End[/COLOR] If
      [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Ac
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
.Range("A:F").ClearContents
c = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
   c = c + 1
   Sp = Split(Dic(K), ",")
   .Range("A1").Value = "Name"
   .Range("A" & c).Value = K
   .Range("B" & c).Resize(, UBound(Sp) + 1) = Sp
   .Range("B1").Resize(, UBound(Sp) + 1) = "Room"
   oMax = Application.Max(UBound(Sp) + 2, oMax)
[COLOR="Navy"]Next[/COLOR] K
    [COLOR="Navy"]With[/COLOR] .Range("A1").Resize(c, oMax)
        .Borders.Weight = 2
        .Columns.AutoFit
    [COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] With

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

Regards Mick

 

[MrTommey232]

first of all, thank you very much for your help.
second, whohoho it's magic...
only one thing left, if the same name stays in the same room from 9 to 12, can I merge it to one cell instead of getting 3 times the same room but differnt hour?
thx again
Tom.

 

[MickG]

You're welcome
I'll have to give some thought to your query.
Regrds Mick

 

[MickG]

Try this for results on sheet2.

[COLOR="Navy"]Sub[/COLOR] MG01Feb20
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] k [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] p [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] H [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer,[/COLOR] Col [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
   
Ray = Cells(1).CurrentRegion.Resize(, 4)
 [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
   
        [COLOR="Navy"]For[/COLOR] n = 2 To UBound(Ray, 1)
            [COLOR="Navy"]For[/COLOR] Ac = 2 To UBound(Ray, 2)
                [COLOR="Navy"]If[/COLOR] Not IsEmpty(Ray(n, Ac)) [COLOR="Navy"]Then[/COLOR]
                    [COLOR="Navy"]If[/COLOR] Not Dic.exists(Ray(n, Ac)) [COLOR="Navy"]Then[/COLOR]
                        [COLOR="Navy"]Set[/COLOR] Dic(Ray(n, Ac)) = CreateObject("Scripting.Dictionary")
                    [COLOR="Navy"]End[/COLOR] If
                    [COLOR="Navy"]If[/COLOR] Not Dic(Ray(n, Ac)).exists(Ray(1, Ac)) [COLOR="Navy"]Then[/COLOR]
                        Dic(Ray(n, Ac)).Add (Ray(1, Ac)), Ray(1, Ac) & "-" & Format(Ray(n, 1), "dd-mmm")
                    [COLOR="Navy"]Else[/COLOR]
                        Dic(Ray(n, Ac)).Item(Ray(1, Ac)) = Dic(Ray(n, Ac)).Item(Ray(1, Ac)) & "/" & Format(Ray(n, 1), "dd-mmm")
                    [COLOR="Navy"]End[/COLOR] If
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]Next[/COLOR] Ac
        [COLOR="Navy"]Next[/COLOR] n
   
   
ReDim nray(1 To UBound(Ray, 1), 1 To UBound(Ray, 2))
  c = 1
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.Keys
        c = c + 1
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] p [COLOR="Navy"]In[/COLOR] Dic(k)
           [COLOR="Navy"]For[/COLOR] H = 2 To UBound(Ray, 2)
              [COLOR="Navy"]If[/COLOR] Ray(1, H) = p Then: Col = H: [COLOR="Navy"]Exit[/COLOR] For
           [COLOR="Navy"]Next[/COLOR] H
            nray(1, 1) = "Names"
            nray(c, 1) = k
            nray(1, Col) = p
            nray(c, Col) = Dic(k).Item(p)
        [COLOR="Navy"]Next[/COLOR] p
   
    [COLOR="Navy"]Next[/COLOR] k
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, UBound(Ray, 2))
    .Parent.UsedRange.Clear
    .Value = nray
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick