Réorganisation de valeurs dans un tableur : help please !

[Hirundo]

Bonjour à tous,

Étant dans une impasse totale (et avec une maîtrise assez limitée des tableurs), je sollicite le forum pour espérer trouver une solution à mon problème. Le voici :

J'ai un tableur avec deux colonnes de type :

48160001 91.5
48160002 46.1
48160002 46.3
48160003 46.3
48160004 13.1
48160004 24.0
48160004 45.0
48160004 46.3
48160006 13.1
48160006 23.0
48160006 81.0
48160006 84.0


Plusieurs références se répètent en colonne 1 ... car plusieurs valeurs sont possibles en colonne 2 ... et cela me pose un problème pour une jointure sous un autre logiciel. Je souhaiterais donc obtenir en face de chaque numéro en colonne en 1 : plusieurs colonnes en ligne avec les valeurs correspondantes issues de la colonne 2. Soit pour exemple :

- 48160002 --> 46.1 et 46.3
- 48160004 --> 13.1 et 24.0 et 45.0 et 46.3

Donc avoir des lignes et si possible, que chaque valeur issues de la colonne 2 soient dans des colonnes différentes ... et plus qu'une seule ligne par numéro en colonne 1.

Merci d'avance pour votre aide !

 

[mapomme]

Bonjour @Hirundo et bienvenue sur XLD ,

• un essai de solution par macro
• le résultat s'affiche à partir de la cellule E1
• cliquer sur le bouton Hop!
• le code est dans module 1

Sub Regrouper()
Dim dico As New Dictionary, t, i&, n&, elem

  With Sheets("Feuil1")
    Application.ScreenUpdating = False
    t = Range("a1:b" & .Cells(.Rows.Count, "a").End(xlUp).Row)
    For i = 1 To UBound(t)
      If Not dico.Exists(t(i, 1)) Then dico.Add t(i, 1), New Dictionary
      n = n + 1: dico(t(i, 1)).Add n, t(i, 2)
    Next i
    .Range("e1").CurrentRegion.Clear
    i = 0
    For Each elem In dico
      .Range("e1").Offset(i) = elem
      .Range("e1").Offset(i, 1).Resize(, dico(elem).Count) = dico(elem).Items
      i = i + 1
    Next elem
  End With
End Sub

 

[job75]

Bonjour Hirundo, mapomme,

@ mapomme sur un grand tableau la restitution cellule par cellule prendra beaucoup de temps !

Voyez le fichier joint et cette macro :

Sub Traitement_doublons()
Dim F As Worksheet, dest As Range, tablo, d As Object, i&, x$
Set F = Feuil1 'CodeName de la feuille, à adapter
Set dest = F.[d2] 'à adapter
Application.ScreenUpdating = False
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
dest.EntireColumn.Resize(, F.Columns.Count - dest.Column).ClearContents 'RAZ
tablo = F.[A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide
Set d = CreateObject("Scripting.dictionary")
For i = 2 To UBound(tablo)
    x = CStr(tablo(i, 1))
    If Not d.exists(x) Then d(x) = tablo(i, 1)
    d(x) = d(x) & " " & tablo(i, 2)
Next
If d.Count = 0 Then Exit Sub
dest.Resize(d.Count) = Application.Transpose(d.items) 'Transpose limitée à 65536 lignes
dest.Resize(d.Count).TextToColumns dest, xlDelimited, Space:=True 'commande Convertir
End Sub

A+

 

[Hirundo]

Bonjour mapomme et job75,
Merci infiniment pour vos retours. Je vais essayer vos méthodes. En effet c'est un grand tableau ... 2 colonnes mais + de 5000 lignes de données. Je suis novice en macro mais vos astuces m'ont boosté. J'essaye de ce pas.
Cindy

 

[Hirundo]

Merci infiniment ... et vraiment mille fois.
Vos deux façons de faire fonctionnent !!!
C'est génial, merci encore.
Cordialement.

 

[mapomme]

Bonsoir @job75,

Je suis d'accord avec toi. Mais je ne ne voulais pas du Transpose et en plus je voulais placer un dico de dico (par pure coquetterie )
Bonne soirée à toi

 

[job75]

Mais je ne ne voulais pas du Transpose

On peut éviter la fonction Transpose et aussi la commande Convertir comme ceci :

Sub Traitement_doublons()
Dim F As Worksheet, dest As Range, tablo, d As Object, i&, x$, a, ubmax%, s, ub%, resu(), j%
Set F = Feuil1 'CodeName de la feuille, à adapter
Set dest = F.[d2] 'à adapter
Application.ScreenUpdating = False
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
dest.EntireColumn.Resize(, F.Columns.Count - dest.Column).ClearContents 'RAZ
tablo = F.[A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide
Set d = CreateObject("Scripting.dictionary")
For i = 2 To UBound(tablo)
    x = CStr(tablo(i, 1))
    If Not d.exists(x) Then d(x) = tablo(i, 1)
    d(x) = d(x) & " " & tablo(i, 2)
Next
If d.Count = 0 Then Exit Sub
'---restitution---
a = d.items
ubmax = -1
For i = 0 To UBound(a)
    s = Split(a(i))
    ub = UBound(s)
    If ub > ubmax Then ubmax = ub: ReDim Preserve resu(UBound(a), ubmax)
    For j = 0 To ub
        If IsNumeric(s(j)) Then resu(i, j) = CDbl(s(j)) Else resu(i, j) = s(j)
    Next
Next
dest.Resize(d.Count, ubmax + 1) = resu
End Sub

Fichier (2).