Fusionner les cellules en fonction d'autres cellules

Bonjour,

Je suis nouveau sur le forum, je vous prie donc d'excuser si je commets des erreurs durant mon post.

Ma demande est la suivante:

Je veux exploiter un big data de 35400 lignes.

Sur la colonne A est marqué les références (qui peuvent revenir dans d'autres lignes n fois) et sur la colonnes B est marqué un commentaire (Texte) :

A B

Ref 1 TXT1

Ref 1 TXT2

Ref2 TXT3

ref 2 TXT4

ref 2 TXT5

ref 3 TXT6

ref 3 TXT7

ref 3 TXT8

ref 3 TXT9

Comment je pourrais faire en utilisant une macro ou autres pour fusionner les cellules de la colonne A en rassemblant les commentaires de la colonne B

A B

Ref1 TXT1 TXT2

Ref2 TXT3 TXT4 TXT5

Ref3 TXT6 TXT7 TXT8 TXT9

Par avance Merci

Bonsoir,

A tester en C1:

=CONCATENER(A1;" ";B1)

Puis copier vers le bas

Cdlt

Renyeu

Bonjour,

avec les REF en colonne A et les TXT en colonne B:

mais rassemblés dans la colonne B

Option Explicit
Sub regroupe()
Dim C, D
Set D = CreateObject("Scripting.Dictionary")
D.CompareMode = vbTextCompare
For Each C In Range("a1", [A65000].End(xlUp))
  If Not D.Exists(C.Value) Then
    D(C.Value) = C.Offset(0, 1)
  Else
    D(C.Value) = D(C.Value) & " " & C.Offset(0, 1)
  End If
Next C
[E2].Resize(D.Count) = Application.Transpose(D.keys)
[F2].Resize(D.Count) = Application.Transpose(D.Items)
End Sub

P.

Bonsoir

en premier lieu, trier votre colonne A par ordre alpha ou numérique, puis après

avoir copier cette macro dans un module, exécuter là :

Sub Transpose_donnees()

Dim Num_Ligne As String

Dim Col_Ecriture As Long

Dim Lig_Ecriture As String

Lig_Ecriture = 1

Num_Ligne = 1

While Cells(Num_Ligne, 1) <> ""

Col_Ecriture = 5

Do

Cells(Lig_Ecriture, Col_Ecriture) = Cells(Num_Ligne, 2)

Col_Ecriture = Col_Ecriture + 1

Num_Ligne = Num_Ligne + 1

Loop While Cells(Num_Ligne - 1, 1) = Cells(Num_Ligne, 1)

Cells(Lig_Ecriture, 4) = Cells(Num_Ligne - 1, 1)

Lig_Ecriture = Lig_Ecriture + 1

Wend

End Sub

Cdlt

cordia5

re,

autre version avec dispersion dans les colonnes à droite

et sans tri préalable ...

Option Explicit
Sub regroupe2()
Dim C, D, a, b, i, col
Set D = CreateObject("Scripting.Dictionary")
D.CompareMode = vbTextCompare
For Each C In Range("a1", [A65000].End(xlUp))
  If Not D.Exists(C.Value) Then
    D(C.Value) = C.Offset(0, 1)
  Else
    D(C.Value) = D(C.Value) & "¦" & C.Offset(0, 1)
  End If
Next C
If D.Count = 0 Then Exit Sub
'---tableau des résultats---
a = D.keys: b = D.items
For i = 0 To UBound(a)
  For col = 0 To UBound(Split(b(i), "¦"))
    Cells(i + 1, col + 5).Value = Split(b(i), "¦")(col)
  Next col
Next i
[D1].Resize(D.Count) = Application.Transpose(D.keys)
End Sub