XL 2016 Regrouper cellule selon critere commun

[bibbip35]

Bonjour à tous

Je cherche a faire une macro. afin de regrouper plusieurs cellule en une ( Valeurs mis a la ligne )
selon un critère commun
J'ai bien pensé en cancaner les cellules , mais au vue du nombre de ligne a traiter ca serait une Opération
longue et fastidieuse

Auriez-vous une idée commun procédé ?

Merci à tous pour votre aide

Bibbip

 

[djidji59430]

Bonjour,

Un TCD ?

 

[bibbip35]

Merci j'avais bien pensé au TCD , mais je souhaiterais avoir toutes les valeurs dans la même cellule

 

[job75]

Bonjour bibibip35, djidji59430,

Le code de la feuille "Résultat" (clic droit sur l'onglet et Visualiser le code) :

Private Sub Worksheet_Activate()
Dim L#, tablo, d As Object, i&, x$, a, b, c$()
With Feuil1 'CodeName de la feuille
    .Columns(2).AutoFit 'ajustement largeur
    L = .Columns(2).ColumnWidth
    tablo = .[A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide
End With
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tablo)
    x = tablo(i, 1)
    d(x) = d(x) & IIf(d.exists(x), vbLf, "") & tablo(i, 2)
Next
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
Cells.Delete 'RAZ
Columns(2).ColumnWidth = 66 'à adapter
'---transposition---
a = d.keys: b = d.items
ReDim c(UBound(a), 1) 'base 0
For i = 0 To UBound(c): c(i, 0) = a(i): c(i, 1) = b(i): Next
'---restitution---
Columns(2).WrapText = True 'renvoi à la ligne
Columns(2).ColumnWidth = L
[A1].Resize(i, 2) = c
End Sub

Fichier joint.

A+

 

[BOISGONTIER]

Bonjour,

Private Sub Worksheet_Activate()
  Set f = Sheets("Fichier de Base")
  Set d1 = CreateObject("Scripting.Dictionary")
  Tbl = f.Range("a1:b" & f.[a65000].End(xlUp).Row).Value
  For i = 1 To UBound(Tbl)
  d1(Tbl(i, 1)) = d1(Tbl(i, 1)) & Tbl(i, 2) & vbCrLf
  Next i
  [A2].Resize(d1.Count) = Application.Transpose(d1.keys)
  [b2].Resize(d1.Count) = Application.Transpose(d1.items)
End Sub

 

[bibbip35]

Merci à vous 2 , c'est juste IMPECABLE !!!

Merci encore et bonne soirée

 

[job75]

Bonjour bibbip35, JB, ke forum,

Chez moi sur Win 10 - Excel 2013 avec la macro de JB il y a un bug sur :

  [b2].Resize(d1.Count) = Application.Transpose(d1.items)

et je ne comprends pas pourquoi !

C'est d'ailleurs pour cette raison que je fais une transposition par boucle.

Bonne journée.

 

[job75]

Re,

Bon j'ai trouvé la raison du bug : la fonction Transpose est limitée à 255 caractères par élément.

Elle est aussi limitée à 65536 éléments.

A+

 

[BOISGONTIER]

Testé avec Excel 2002,Excel 2007,Excel 2010,Excel 2016

Private Sub Worksheet_Activate()
  Set f = Sheets("Fichier de Base")
  Set d1 = CreateObject("Scripting.Dictionary")
  TblE = f.Range("a1:b" & f.[a65000].End(xlUp).Row).Value
  For i = 1 To UBound(TblE)
    d1(TblE(i, 1)) = d1(TblE(i, 1)) & TblE(i, 2) & vbCrLf
  Next i
  [A2].Resize(d1.Count) = Application.Transpose(d1.keys)   ' 65000 clés maxi
  TblItems = d1.items: ReDim TblItems2(1 To d1.Count, 1 To 1)
  For i = 1 To d1.Count: TblItems2(i, 1) = TblItems(i - 1): Next i
  [b2].Resize(d1.Count) = TblItems2
End Sub

Boisgontier

 

[job75]

Re JB,

Tu dis "Toutes versions", ça veux dire que chez toi les éléments de Application.Transpose peuvent contenir plus de 255 caractères ?

Ce serait vraiment curieux.

A+