XL 2010 Concatener des cellules identiques et separer par statut.

Sub Conaténer2()
Dim TRés(1 To 1000, 1 To 3), Statut As SsGr, Chambre As SsGr, Détail, L As Long, TPn() As String, N As Long
For Each Statut In Gigogne(WshBase, 5, 4, Null, -3, 2)
   For Each Chambre In Statut.Co
      L = L + 1
      ReDim TPn(1 To Chambre.Count): N = 0
      For Each Détail In Chambre.Co: N = N + 1: TPn(N) = Détail(2): Next Détail
      TRés(L, 1) = Join(TPn, " & ")
      TRés(L, 2) = Chambre.Id
      TRés(L, 3) = Statut.Id
      Next Chambre, Statut
Sheet3.[F2].Resize(1000, 3).Value = TRés
End Sub

Sub Concaténer()
Dim AUTRES As Collection, GOLD As Collection
Set AUTRES = Gigogne(WshBase, 5, 4, Null, -3, 2)
Set GOLD = New Collection: GOLD.Add AUTRES("GOLD"), "GOLD"
Sortir GOLD, Sheet1: AUTRES.Remove "GOLD"
Set GOLD = New Collection: GOLD.Add AUTRES("PLATINIUM"), "PLATINIUM"
Sortir GOLD, Sheet2: AUTRES.Remove "PLATINIUM"
Sortir AUTRES, Sheet3
End Sub
Private Sub Sortir(ByVal ClnDonnées As Collection, Wsh As Worksheet)
Dim TRés(1 To 1000, 1 To 3), Statut As SsGr, Chambre As SsGr, Détail, L As Long, TPn() As String, N As Long
For Each Statut In ClnDonnées
   For Each Chambre In Statut.Co
      L = L + 1
      ReDim TPn(1 To Chambre.Count): N = 0
      For Each Détail In Chambre.Co: N = N + 1: TPn(N) = Détail(2): Next Détail
      TRés(L, 1) = Join(TPn, " & ")
      TRés(L, 2) = Chambre.Id
      TRés(L, 3) = Statut.Id
      Next Chambre, Statut
Wsh.[F2].Resize(1000, 3).Value = TRés
End Sub