Regrouper sur même ligne les données d'autres ligne selon valeur de cellule

[techtrad]

Bonjour, premier message sur votre forum..je vais tenter d'être clair.

Je souhaite regrouper des données de transactions selon la valeur d'une cellule comme ceci par exemple

Tableau de départ
Colonne A / Colonne B / Colonne C / Colonne D ...
155 / article a / 1 / 15.00€
155 / article b / 2 / 19.00€
155 / article c / 1 / 14.00€
159 / article a / 1 / 20.00€
185 / article a / 2 / 15.00€
191 / article a / 1 / 5.00€
191 / article b / 1 / 7.00€

je souhaite regrouper sur une lignes les articles dont la valeur de la 1ere cellule est identique.
Il peut y avoir 6 articles pour la même transaction par exemple ou qu'un seul.
Au final je souhaite avoir une seule ligne par transaction comme cela :

Colonne A / Colonne B / Colonne C / Colonne D / Colonne E / Colonne F.....
155 / article a / 1 / 15.00€ / article b / 2 / 19.00€ / article c / 1 / 14.00€
159 / article a / 1 / 20.00€
185 / article a / 2 / 15.00€
191 / article a / 1 / 5.00€ / article b / 1 / 7.00€

Il faudrait que je fasse une macro mais je ne sais vers quel méthode me diriger... je pratique les macros mais surtout en enregistrement..

Merci d'avance au pro d'excel qui pourront m'aiguiller

 

[pierrejean]

Re : Regrouper sur même ligne les données d'autres ligne selon valeur de cellule

Bonjour techtrad

Vois si cela te convient

 

[techtrad]

Re : Regrouper sur même ligne les données d'autres ligne selon valeur de cellule

Ouhaouuuuu c'est du rapide.

Avec cela j'ai une super base je vais pouvoir le modifier pour l'adapter (mes lignes comportent plus de 4 cellules).

C'est la 1ere fois que je pose une question sur ce type de forum et je ne suis pas déçu.

Merci mille fois pierrejean bon week end

 

[job75]

Re : Regrouper sur même ligne les données d'autres ligne selon valeur de cellule

Bonjour techtrad, bienvenue sur XLD,

La macro dans la feuille RESULTAT (clic droit sur l'onglet et Visualiser le code) :

Private Sub Worksheet_Activate()
Dim r As Range, d As Object, cc%, lig&, col%
With Feuil1 'CodeName de la feuille source
  Set r = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
  Set d = CreateObject("Scripting.Dictionary")
  cc = Columns.Count
  lig = 2
  '---transferts par copier/coller---
  Application.ScreenUpdating = False
  Cells.Clear 'RAZ
  For Each r In r
    If d.exists(r.Value) Then
      col = Cells(d(r.Value), cc).End(xlToLeft).Column + 1
      r(1, 2).Resize(, 3).Copy Cells(d(r.Value), col)
    Else
      d(r.Value) = lig 'la ligne est mémorisée
      r.Resize(, 4).Copy Cells(lig, 1)
      lig = lig + 1
    End If
  Next
  '---titres---
  .[A1].Copy Cells(1, 1)
  col = Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column
  .[B1:D1].Copy Cells(1, 2).Resize(, col - 1)
End With
End Sub

Elle se lance quand on active la feuille.

Fichier joint.

Edit : ouh là, très à la bourre moi, salut Pierre

A+

 

[job75]

Re : Regrouper sur même ligne les données d'autres ligne selon valeur de cellule

Re,

J'ai créé 1000 tableaux 7 x 4 tous différents jusqu'à la ligne 7001.

Sur mon ordi (Excel 2003), la macro de pierrejean s'exécute en 1,98 s, la mienne en 8,84 secondes.

Le copier/coller prend nettement plus de temps mais il restitue les formats.

A+

 

[job75]

Re : Regrouper sur même ligne les données d'autres ligne selon valeur de cellule

Bonjour techtrad, pierrejean, le forum,

Maintenant cette macro ne transfère que les valeurs :

Private Sub Worksheet_Activate()
Dim ncol%, dercol%, t, rest(), d As Object, i&, s, lig&, col%, j%, L&
ncol = 4 'nombre de colonnes du tableau, à adapter
dercol = ncol
With Feuil1 'CodeName de la feuille source, à adapter
  t = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).Resize(, ncol)
  ReDim rest(1 To UBound(t), 1 To Columns.Count)
  Set d = CreateObject("Scripting.Dictionary")
  '---transfert des valeurs---
  For i = 1 To UBound(t)
    If d.exists(t(i, 1)) Then
      s = Split(d(t(i, 1)))
      lig = s(0): col = s(1)
      For j = 1 To ncol - 1
        rest(lig, col + j) = t(i, j + 1)
      Next
      col = col + ncol - 1
      d(t(i, 1)) = lig & " " & col 'mise à jour mémorisation
      If col > dercol Then dercol = col
    Else
      L = L + 1
      d(t(i, 1)) = L & " " & ncol 'ligne et colonne mémorisées
      For j = 1 To ncol
        rest(L, j) = t(i, j)
      Next
    End If
  Next
  '---restitution et titres---
  Application.ScreenUpdating = False
  Cells.ClearContents 'RAZ
  [A2].Resize(L, dercol) = rest
  .[A1].Copy [A1]
  .[B1].Resize(, ncol - 1).Copy [B1].Resize(, dercol - 1)
End With
End Sub

Edit : [A2].Resize(L, dercol) = rest nettement mieux que [A2].Resize(UBound(t), dercol) = rest

Fichier (2).

Sur mon fichier de test avec 7000 lignes la macro s'exécute en 0,34 seconde.

C'est très rapide car on utilise des tableaux VBA.

A+

 

[job75]

Re : Regrouper sur même ligne les données d'autres ligne selon valeur de cellule

Re,

Noter qu'on peut n'utiliser qu'un seul tableau VBA :

Private Sub Worksheet_Activate()
Dim ncol%, dercol%, t(), d As Object, i&, s, lig&, col%, j%, L&
ncol = 4 'nombre de colonnes du tableau, à adapter
dercol = ncol
With Feuil1 'CodeName de la feuille source, à adapter
  t = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).Resize(, ncol)
  ReDim Preserve t(1 To UBound(t), 1 To .Columns.Count) 'agrandissement
  Set d = CreateObject("Scripting.Dictionary")
  '---transfert des valeurs---
  For i = 1 To UBound(t)
    If d.exists(t(i, 1)) Then
      s = Split(d(t(i, 1)))
      lig = s(0): col = s(1)
      For j = 1 To ncol - 1
        t(lig, col + j) = t(i, j + 1)
      Next
      col = col + ncol - 1
      d(t(i, 1)) = lig & " " & col 'mise à jour mémorisation
      If col > dercol Then dercol = col
    Else
      L = L + 1
      d(t(i, 1)) = L & " " & ncol 'ligne et colonne mémorisées
      For j = 1 To ncol
        t(L, j) = t(i, j)
      Next
    End If
  Next
  '---restitution et titres---
  Application.ScreenUpdating = False
  Cells.ClearContents 'RAZ
  [A2].Resize(L, dercol) = t
  .[A1].Copy [A1]
  .[B1].Resize(, ncol - 1).Copy [B1].Resize(, dercol - 1)
End With
End Sub

C'est plus élégant mais pas plus rapide.

Fichier (2 bis).

A+

 

[job75]

Re : Regrouper sur même ligne les données d'autres ligne selon valeur de cellule

Re,

Par contre, en redimensionnant le tableau quand c'est nécessaire, ceci est un peu plus rapide :

Private Sub Worksheet_Activate()
Dim ncol%, dercol%, t(), u&, d As Object, i&, s, lig&, col%, v%, j%, L&
ncol = 4 'nombre de colonnes du tableau, à adapter
dercol = ncol
With Feuil1 'CodeName de la feuille source, à adapter
  t = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).Resize(, ncol)
  u = UBound(t)
  Set d = CreateObject("Scripting.Dictionary")
  '---transfert des valeurs---
  For i = 1 To u
    If d.exists(t(i, 1)) Then
      s = Split(d(t(i, 1)))
      lig = s(0): col = s(1)
      v = col + ncol - 1
      If v > dercol Then dercol = v: ReDim Preserve t(1 To u, 1 To v)
      For j = 1 To ncol - 1
        t(lig, col + j) = t(i, j + 1)
      Next
      d(t(i, 1)) = lig & " " & v 'mise à jour mémorisation
    Else
      L = L + 1
      d(t(i, 1)) = L & " " & ncol 'ligne et colonne mémorisées
      For j = 1 To ncol
        t(L, j) = t(i, j)
      Next
    End If
  Next
  '---restitution et titres---
  Application.ScreenUpdating = False
  Cells.ClearContents 'RAZ
  [A2].Resize(L, dercol) = t
  .[A1].Copy [A1]
  .[B1].Resize(, ncol - 1).Copy [B1].Resize(, dercol - 1)
End With
End Sub

Fichier (3).

Sur 7000 lignes 0,29 seconde.

A+

 

[job75]

Re : Regrouper sur même ligne les données d'autres ligne selon valeur de cellule

Bonjour pierrejean, le forum,

Merci pour le Like mais je n'ai pas fini

En mémorisant la colonne dans un tableau au lieu de la concaténer c'est encore un peu plus rapide :

Private Sub Worksheet_Activate()
Dim ncol%, dercol%, t(), u&, d As Object, i&, lig&, col%, v%, j%, L&, memcol%()
ncol = 4 'nombre de colonnes du tableau, à adapter
dercol = ncol
With Feuil1 'CodeName de la feuille source, à adapter
  t = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)(3)).Resize(, ncol)
  u = UBound(t)
  Set d = CreateObject("Scripting.Dictionary")
  '---transfert des valeurs---
  For i = 1 To u
    If d.exists(t(i, 1)) Then
      lig = d(t(i, 1)): col = memcol(lig)
      v = col + ncol - 1
      If v > dercol Then dercol = v: ReDim Preserve t(1 To u, 1 To v)
      For j = 1 To ncol - 1
        t(lig, col + j) = t(i, j + 1)
      Next
      memcol(lig) = v 'mise à jour mémorisation colonne
    Else
      L = L + 1
      d(t(i, 1)) = L 'ligne mémorisée
      ReDim Preserve memcol(1 To L)
      memcol(L) = ncol 'colonne mémorisée
      For j = 1 To ncol
        t(L, j) = t(i, j)
      Next
    End If
  Next
  '---restitution et titres---
  Application.ScreenUpdating = False
  Cells.ClearContents 'RAZ
  [A2].Resize(L, dercol) = t
  .[A1].Copy [A1]
  If ncol > 1 Then .[B1].Resize(, ncol - 1).Copy [B1].Resize(, dercol - 1)
End With
End Sub

Fichier (4).

Sur 7000 lignes 0,26 seconde.

A+